import Logs.AdjustedBranchUpdate
import Utility.FileMode
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import Data.Time.Clock.POSIX
import qualified Data.Map as M
-- origbranch.
_ <- propigateAdjustedCommits' True origbranch adj commitlck
- origheadfile <- inRepo $ readFileStrict . Git.Ref.headFile
+ origheadfile <- inRepo $ F.readFile' . toOsPath . Git.Ref.headFile
origheadsha <- inRepo (Git.Ref.sha currbranch)
b <- adjustBranch adj origbranch
newheadfile <- case origheadsha of
Just s -> do
inRepo $ \r -> do
- let newheadfile = fromRef s
- writeFile (Git.Ref.headFile r) newheadfile
+ let newheadfile = fromRef' s
+ F.writeFile' (toOsPath (Git.Ref.headFile r)) newheadfile
return (Just newheadfile)
_ -> return Nothing
unless ok $ case newheadfile of
Nothing -> noop
Just v -> preventCommits $ \_commitlck -> inRepo $ \r -> do
- v' <- readFileStrict (Git.Ref.headFile r)
+ v' <- F.readFile' (toOsPath (Git.Ref.headFile r))
when (v == v') $
- writeFile (Git.Ref.headFile r) origheadfile
+ F.writeFile' (toOsPath (Git.Ref.headFile r)) origheadfile
return ok
| otherwise = preventCommits $ \commitlck -> do
import Utility.Tmp.Dir
import Utility.CopyFile
import Utility.Directory.Create
+import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
-import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
canMergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Annex Bool
-}
changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do
git_dir <- fromRepo Git.localGitDir
- let git_dir' = fromRawFilePath git_dir
tmpwt <- fromRepo gitAnnexMergeDir
- withTmpDirIn (fromRawFilePath othertmpdir) "git" $ \tmpgit -> withWorkTreeRelated tmpgit $
+ withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $
withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do
+ let tmpgit' = toRawFilePath tmpgit
liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)
-- Copy in refs and packed-refs, to work
-- around bug in git 2.13.0, which
-- causes it not to look in GIT_DIR for refs.
refs <- liftIO $ emptyWhenDoesNotExist $
dirContentsRecursive $
- git_dir' </> "refs"
- let refs' = (git_dir' </> "packed-refs") : refs
+ git_dir P.</> "refs"
+ let refs' = (git_dir P.</> "packed-refs") : refs
liftIO $ forM_ refs' $ \src -> do
- let src' = toRawFilePath src
- whenM (doesFileExist src) $ do
- dest <- relPathDirToFile git_dir src'
- let dest' = toRawFilePath tmpgit P.</> dest
+ whenM (R.doesPathExist src) $ do
+ dest <- relPathDirToFile git_dir src
+ let dest' = tmpgit' P.</> dest
createDirectoryUnder [git_dir]
(P.takeDirectory dest')
- void $ createLinkOrCopy src' dest'
+ void $ createLinkOrCopy src dest'
-- This reset makes git merge not care
-- that the work tree is empty; otherwise
-- it will think that all the files have
if merged
then do
!mergecommit <- liftIO $ extractSha
- <$> S.readFile (tmpgit </> "HEAD")
+ <$> F.readFile' (toOsPath (tmpgit' P.</> "HEAD"))
-- This is run after the commit lock is dropped.
return $ postmerge mergecommit
else return $ return False
import Utility.InodeCache
import Utility.FileMode
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import qualified Data.Set as S
import qualified Data.Map as M
-import qualified Data.ByteString.Lazy as L
import System.PosixCompat.Files (isSymbolicLink)
{- Merges from a branch into the current branch (which may not exist yet),
| otherwise = pure f
makesymlink key dest = do
- l <- calcRepo $ gitAnnexLink (toRawFilePath dest) key
- unless inoverlay $ replacewithsymlink dest l
+ let rdest = toRawFilePath dest
+ l <- calcRepo $ gitAnnexLink rdest key
+ unless inoverlay $ replacewithsymlink rdest l
dest' <- toRawFilePath <$> stagefile dest
stageSymlink dest' =<< hashSymlink l
let replacefile isexecutable = case selectwant' (LsFiles.unmergedSha u) of
Nothing -> noop
- Just sha -> replaceWorkTreeFile item $ \tmp -> do
+ Just sha -> replaceWorkTreeFile (toRawFilePath item) $ \tmp -> do
c <- catObject sha
- liftIO $ L.writeFile (decodeBS tmp) c
+ liftIO $ F.writeFile (toOsPath tmp) c
when isexecutable $
liftIO $ void $ tryIO $
modifyFileMode tmp $
Nothing -> noop
Just sha -> do
link <- catSymLinkTarget sha
- replacewithsymlink item link
+ replacewithsymlink (toRawFilePath item) link
(Just TreeFile, Just TreeSymlink) -> replacefile False
(Just TreeExecutable, Just TreeSymlink) -> replacefile True
_ -> ifM (liftIO $ doesDirectoryExist item)
import Types.UUID
import Utility.Hash
-import Data.List
import Data.Maybe
import Data.Bits (shiftL)
import qualified Data.Set as S
import qualified Data.ByteArray as BA
+import Data.List
+import Prelude
-- The Int is how many UUIDs to pick.
type BalancedPicker = S.Set UUID -> Key -> Int -> [UUID]
import Utility.Directory.Stream
import Utility.Tmp
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
{- Name of the branch that is used to store git-annex's information. -}
name :: Git.Ref
{- Checks if the index needs to be updated. -}
needUpdateIndex :: Git.Ref -> Annex Bool
needUpdateIndex branchref = do
- f <- fromRawFilePath <$> fromRepo gitAnnexIndexStatus
+ f <- toOsPath <$> fromRepo gitAnnexIndexStatus
committedref <- Git.Ref . firstLine' <$>
- liftIO (catchDefaultIO mempty $ B.readFile f)
+ liftIO (catchDefaultIO mempty $ F.readFile' f)
return (committedref /= branchref)
{- Record that the branch's index has been updated to correspond to a
g <- gitRepo
st <- getState
let dir = gitAnnexJournalDir st g
- (jlogf, jlogh) <- openjlog (fromRawFilePath tmpdir)
+ (jlogf, jlogh) <- openjlog tmpdir
withHashObjectHandle $ \h ->
withJournalHandle gitAnnexJournalDir $ \jh ->
Git.UpdateIndex.streamUpdateIndex g
genstream dir h jh jlogh streamer = readDirectory jh >>= \case
Nothing -> return ()
Just file -> do
- let path = dir P.</> toRawFilePath file
+ let path = dir P.</> file
unless (dirCruft file) $ whenM (isfile path) $ do
sha <- Git.HashObject.hashFile h path
- hPutStrLn jlogh file
+ B.hPutStr jlogh (file <> "\n")
streamer $ Git.UpdateIndex.updateIndexLine
- sha TreeFile (asTopFilePath $ fileJournal $ toRawFilePath file)
+ sha TreeFile (asTopFilePath $ fileJournal file)
genstream dir h jh jlogh streamer
isfile file = isRegularFile <$> R.getFileStatus file
-- Clean up the staged files, as listed in the temp log file.
stagedfs <- lines <$> hGetContents jlogh
mapM_ (removeFile . (dir </>)) stagedfs
hClose jlogh
- removeWhenExistsWith (R.removeLink) (toRawFilePath jlogf)
- openjlog tmpdir = liftIO $ openTmpFileIn tmpdir "jlog"
+ removeWhenExistsWith (R.removeLink) (fromOsPath jlogf)
+ openjlog tmpdir = liftIO $ openTmpFileIn (toOsPath tmpdir) (toOsPath "jlog")
getLocalTransitions :: Annex Transitions
getLocalTransitions =
S.fromList . mapMaybe Git.Sha.extractSha . fileLines' <$> content
where
content = do
- f <- fromRawFilePath <$> fromRepo gitAnnexIgnoredRefs
- liftIO $ catchDefaultIO mempty $ B.readFile f
+ f <- toOsPath <$> fromRepo gitAnnexIgnoredRefs
+ liftIO $ catchDefaultIO mempty $ F.readFile' f
addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex ()
addMergedRefs [] = return ()
getMergedRefs' :: Annex [(Git.Sha, Git.Branch)]
getMergedRefs' = do
- f <- fromRawFilePath <$> fromRepo gitAnnexMergedRefs
- s <- liftIO $ catchDefaultIO mempty $ B.readFile f
+ f <- toOsPath <$> fromRepo gitAnnexMergedRefs
+ s <- liftIO $ catchDefaultIO mempty $ F.readFile' f
return $ map parse $ fileLines' s
where
parse l =
import qualified Git
import Git.Sha
import qualified Utility.SimpleProtocol as Proto
+import qualified Utility.FileIO as F
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TBMChan
-import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
newtype ChangedRefs = ChangedRefs [Git.Ref]
| ".lock" `isSuffixOf` reffile = noop
| otherwise = void $ do
sha <- catchDefaultIO Nothing $
- extractSha <$> S.readFile reffile
+ extractSha <$> F.readFile' (toOsPath (toRawFilePath reffile))
-- When the channel is full, there is probably no reader
-- running, or ref changes have been occurring very fast,
-- so it's ok to not write the change to it.
import Utility.TimeStamp
import Utility.FileMode
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isSymbolicLink, linkCount)
-}
linkFromAnnex :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult
linkFromAnnex key dest destmode =
- replaceFile' (const noop) (fromRawFilePath dest) (== LinkAnnexOk) $ \tmp ->
+ replaceFile' (const noop) dest (== LinkAnnexOk) $ \tmp ->
linkFromAnnex' key tmp destmode
{- This is only safe to use when dest is not a worktree file. -}
s <- Annex.getState id
r <- Annex.getRead id
depth <- gitAnnexLocationDepth <$> Annex.getGitConfig
- liftIO $ walk (s, r) depth (fromRawFilePath dir)
+ liftIO $ walk (s, r) depth dir
where
walk s depth dir = do
contents <- catchDefaultIO [] (dirContents dir)
then do
contents' <- filterM present contents
keys <- filterM (Annex.eval s . want) $
- mapMaybe (fileKey . P.takeFileName . toRawFilePath) contents'
+ mapMaybe (fileKey . P.takeFileName) contents'
continue keys []
else do
let deeper = walk s (depth - 1)
present _ | inanywhere = pure True
present d = presentInAnnex d
- presentInAnnex = doesFileExist . contentfile
- contentfile d = d </> takeFileName d
+ presentInAnnex = R.doesPathExist . contentfile
+ contentfile d = d P.</> P.takeFileName d
{- Things to do to record changes to content when shutting down.
-
modifyContentDirWhenExists lckfile $ bracket (lock lckfile) unlock $ \_ ->
readContentRetentionTimestamp rt >>= \case
Just ts | ts >= t -> return ()
- _ -> replaceFile (const noop) (fromRawFilePath rt) $ \tmp ->
+ _ -> replaceFile (const noop) rt $ \tmp ->
liftIO $ writeFile (fromRawFilePath tmp) $ show t
where
lock = takeExclusiveLock
readContentRetentionTimestamp :: RawFilePath -> Annex (Maybe POSIXTime)
readContentRetentionTimestamp rt =
liftIO $ join <$> tryWhenExists
- (parsePOSIXTime <$> readFile (fromRawFilePath rt))
+ (parsePOSIXTime <$> F.readFile' (toOsPath rt))
{- Checks if the retention timestamp is in the future, if so returns
- Nothing.
populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
where
go (Just k') | k == k' = do
- let f' = fromRawFilePath f
destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f
liftIO $ removeWhenExistsWith R.removeLink f
- (ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do
+ (ic, populated) <- replaceWorkTreeFile f $ \tmp -> do
ok <- linkOrCopy k obj tmp destmode >>= \case
Just _ -> thawContent tmp >> return True
Nothing -> liftIO (writePointerFile tmp k destmode) >> return False
let mode = fmap fileMode st
secureErase file
liftIO $ removeWhenExistsWith R.removeLink file
- ic <- replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
+ ic <- replaceWorkTreeFile file $ \tmp -> do
liftIO $ writePointerFile tmp key mode
#if ! defined(mingw32_HOST_OS)
-- Don't advance mtime; this avoids unnecessary re-smudging
import Utility.Exception
import Utility.Monad
import Utility.FileSystemEncoding
+import Utility.SystemDirectory
import qualified Utility.RawFilePath as R
import Utility.PartialPrelude
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Annex.Hook where
import Annex.Common
hookWarning h msg = do
r <- gitRepo
warning $ UnquotedString $
- Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg
+ fromRawFilePath (Git.hookName h) ++
+ " hook (" ++ fromRawFilePath (Git.hookFile h r) ++ ") " ++ msg
{- To avoid checking if the hook exists every time, the existing hooks
- are cached. -}
( return Nothing
, do
h <- fromRepo (Git.hookFile hook)
- commandfailed h
+ commandfailed (fromRawFilePath h)
)
runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case
Nothing -> return Nothing
withhardlink tmpdir = do
setperms
withTSDelta $ \delta -> liftIO $ do
- (tmpfile, h) <- openTmpFileIn (fromRawFilePath tmpdir) $
- relatedTemplate $ "ingest-" ++ takeFileName file
+ (tmpfile, h) <- openTmpFileIn (toOsPath tmpdir) $
+ relatedTemplate $ toRawFilePath $
+ "ingest-" ++ takeFileName file
hClose h
- removeWhenExistsWith R.removeLink (toRawFilePath tmpfile)
- withhardlink' delta tmpfile
+ let tmpfile' = fromOsPath tmpfile
+ removeWhenExistsWith R.removeLink tmpfile'
+ withhardlink' delta tmpfile'
`catchIO` const (nohardlink' delta)
withhardlink' delta tmpfile = do
- let tmpfile' = toRawFilePath tmpfile
- R.createLink file' tmpfile'
- cache <- genInodeCache tmpfile' delta
+ R.createLink file' tmpfile
+ cache <- genInodeCache tmpfile delta
return $ LockedDown cfg $ KeySource
{ keyFilename = file'
- , contentLocation = tmpfile'
+ , contentLocation = tmpfile
, inodeCache = cache
}
makeLink :: RawFilePath -> Key -> Maybe InodeCache -> Annex LinkTarget
makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
l <- calcRepo $ gitAnnexLink file key
- replaceWorkTreeFile file' $ makeAnnexLink l
+ replaceWorkTreeFile file $ makeAnnexLink l
-- touch symlink to have same time as the original file,
-- as provided in the InodeCache
Nothing -> noop
return l
- where
- file' = fromRawFilePath file
{- Creates the symlink to the annexed content, and stages it in git. -}
addSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex ()
import Types.BranchState
import Utility.Directory.Stream
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L
-- journal file is written atomically
let jfile = journalFile file
let tmpfile = tmp P.</> jfile
- liftIO $ withFile (fromRawFilePath tmpfile) WriteMode $ \h ->
+ liftIO $ F.withFile (toOsPath tmpfile) WriteMode $ \h ->
writeJournalHandle h content
let dest = jd P.</> jfile
let mv = do
-}
appendJournalFile :: Journalable content => JournalLocked -> AppendableJournalFile -> content -> Annex ()
appendJournalFile _jl (AppendableJournalFile (jd, jfile)) content = do
- let write = liftIO $ withFile (fromRawFilePath jfile) ReadWriteMode $ \h -> do
+ let write = liftIO $ F.withFile (toOsPath jfile) ReadWriteMode $ \h -> do
sz <- hFileSize h
when (sz /= 0) $ do
hSeek h SeekFromEnd (-1)
jfile = journalFile file
getfrom d = catchMaybeIO $
discardIncompleteAppend . L.fromStrict
- <$> B.readFile (fromRawFilePath (d P.</> jfile))
+ <$> F.readFile' (toOsPath (d P.</> jfile))
-- Note that this forces read of the whole lazy bytestring.
discardIncompleteAppend :: L.ByteString -> L.ByteString
where
-- avoid overhead of creating the journal directory when it already
-- exists
- opendir d = liftIO (openDirectory (fromRawFilePath d))
+ opendir d = liftIO (openDirectory d)
`catchIO` (const (createAnnexDirectory d >> opendir d))
{- Checks if there are changes in the journal. -}
journalDirty :: (BranchState -> Git.Repo -> RawFilePath) -> Annex Bool
journalDirty getjournaldir = do
st <- getState
- d <- fromRawFilePath <$> fromRepo (getjournaldir st)
- liftIO $
- (not <$> isDirectoryEmpty d)
- `catchIO` (const $ doesDirectoryExist d)
+ d <- fromRepo (getjournaldir st)
+ liftIO $ isDirectoryPopulated d
{- Produces a filename to use in the journal for a file on the branch.
- The filename does not include the journal directory.
import Utility.CopyFile
import qualified Database.Keys.Handle
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
probesymlink = R.readSymbolicLink file
- probefilecontent = withFile (fromRawFilePath file) ReadMode $ \h -> do
+ probefilecontent = F.withFile (toOsPath file) ReadMode $ \h -> do
s <- S.hGet h maxSymlinkSz
-- If we got the full amount, the file is too large
-- to be a symlink target.
( liftIO $ do
void $ tryIO $ R.removeLink file
R.createSymbolicLink linktarget file
- , liftIO $ S.writeFile (fromRawFilePath file) linktarget
+ , liftIO $ F.writeFile' (toOsPath file) linktarget
)
{- Creates a link on disk, and additionally stages it in git. -}
writePointerFile :: RawFilePath -> Key -> Maybe FileMode -> IO ()
writePointerFile file k mode = do
- S.writeFile (fromRawFilePath file) (formatPointer k)
+ F.writeFile' (toOsPath file) (formatPointer k)
maybe noop (R.setFileMode file) mode
newtype Restage = Restage Bool
when (numfiles > 0) $
bracket lockindex unlockindex go
where
- withtmpdir = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex"
+ withtmpdir = withTmpDirIn
+ (fromRawFilePath $ Git.localGitDir r)
+ (toOsPath "annexindex")
isunmodified tsd f orig =
genInodeCache f tsd >>= return . \case
isPointerFile :: RawFilePath -> IO (Maybe Key)
isPointerFile f = catchDefaultIO Nothing $
#if defined(mingw32_HOST_OS)
- withFile (fromRawFilePath f) ReadMode readhandle
+ F.withFile (toOsPath f) ReadMode readhandle
#else
#if MIN_VERSION_unix(2,8,0)
let open = do
#else
ifM (isSymbolicLink <$> R.getSymbolicLinkStatus f)
( return Nothing
- , withFile (fromRawFilePath f) ReadMode readhandle
+ , F.withFile (toOsPath f) ReadMode readhandle
)
#endif
#endif
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
module Annex.Proxy where
import Utility.Metered
import Git.Types
import qualified Database.Export as Export
+import qualified Utility.FileIO as F
#ifndef mingw32_HOST_OS
import Utility.OpenFile
#endif
-- independently. Also, this key is not getting added into the
-- local annex objects.
withproxytmpfile k a = withOtherTmp $ \othertmpdir ->
- withTmpDirIn (fromRawFilePath othertmpdir) "proxy" $ \tmpdir ->
+ withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "proxy") $ \tmpdir ->
a (toRawFilePath tmpdir P.</> keyFile k)
proxyput af k = do
-- the client, to avoid bad content
-- being stored in the special remote.
iv <- startVerifyKeyContentIncrementally Remote.AlwaysVerify k
- h <- liftIO $ openFile (fromRawFilePath tmpfile) WriteMode
+ h <- liftIO $ F.openFile (toOsPath tmpfile) WriteMode
let nuketmp = liftIO $ removeWhenExistsWith removeFile (fromRawFilePath tmpfile)
gotall <- liftIO $ receivetofile iv h len
liftIO $ hClose h
{- git-annex file replacing
-
- - Copyright 2013-2021 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2025 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE CPP #-}
-
module Annex.ReplaceFile (
replaceGitAnnexDirFile,
replaceGitDirFile,
import Annex.Tmp
import Annex.Perms
import Git
+import Utility.Tmp
import Utility.Tmp.Dir
import Utility.Directory.Create
-#ifndef mingw32_HOST_OS
-import Utility.Path.Max
-#endif
+
+import qualified System.FilePath.ByteString as P
{- replaceFile on a file located inside the gitAnnexDir. -}
-replaceGitAnnexDirFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a
+replaceGitAnnexDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
replaceGitAnnexDirFile = replaceFile createAnnexDirectory
{- replaceFile on a file located inside the .git directory. -}
-replaceGitDirFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a
+replaceGitDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
replaceGitDirFile = replaceFile $ \dir -> do
top <- fromRepo localGitDir
liftIO $ createDirectoryUnder [top] dir
{- replaceFile on a worktree file. -}
-replaceWorkTreeFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a
+replaceWorkTreeFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
replaceWorkTreeFile = replaceFile createWorkTreeDirectory
{- Replaces a possibly already existing file with a new version,
- The createdirectory action is only run when moving the file into place
- fails, and can create any parent directory structure needed.
-}
-replaceFile :: (RawFilePath -> Annex ()) -> FilePath -> (RawFilePath -> Annex a) -> Annex a
+replaceFile :: (RawFilePath -> Annex ()) -> RawFilePath -> (RawFilePath -> Annex a) -> Annex a
replaceFile createdirectory file action = replaceFile' createdirectory file (const True) action
-replaceFile' :: (RawFilePath -> Annex ()) -> FilePath -> (a -> Bool) -> (RawFilePath -> Annex a) -> Annex a
+replaceFile' :: (RawFilePath -> Annex ()) -> RawFilePath -> (a -> Bool) -> (RawFilePath -> Annex a) -> Annex a
replaceFile' createdirectory file checkres action = withOtherTmp $ \othertmpdir -> do
- let othertmpdir' = fromRawFilePath othertmpdir
-#ifndef mingw32_HOST_OS
- -- Use part of the filename as the template for the temp
- -- directory. This does not need to be unique, but it
- -- makes it more clear what this temp directory is for.
- filemax <- liftIO $ fileNameLengthLimit othertmpdir'
- let basetmp = take (filemax `div` 2) (takeFileName file)
-#else
- -- Windows has limits on the whole path length, so keep
- -- it short.
- let basetmp = "t"
-#endif
- withTmpDirIn othertmpdir' basetmp $ \tmpdir -> do
- let tmpfile = toRawFilePath (tmpdir </> basetmp)
+ let basetmp = relatedTemplate' (P.takeFileName file)
+ withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath basetmp) $ \tmpdir -> do
+ let tmpfile = toRawFilePath tmpdir P.</> basetmp
r <- action tmpfile
when (checkres r) $
- replaceFileFrom tmpfile (toRawFilePath file) createdirectory
+ replaceFileFrom tmpfile file createdirectory
return r
replaceFileFrom :: RawFilePath -> RawFilePath -> (RawFilePath -> Annex ()) -> Annex ()
where
go livedir lck pidlockfile now = do
void $ tryNonAsync $ do
- lockfiles <- liftIO $ filter (not . dirCruft)
+ lockfiles <- liftIO $ filter (not . dirCruft . toRawFilePath)
<$> getDirectoryContents (fromRawFilePath livedir)
stale <- forM lockfiles $ \lockfile ->
if (lockfile /= pidlockfile)
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Annex.Ssh (
{- Returns a filename to use for a ssh connection caching socket, and
- parameters to enable ssh connection caching. -}
-sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
+sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe RawFilePath, [CommandParam])
sshCachingInfo (host, port) = go =<< sshCacheDir'
where
go (Right dir) =
liftIO (bestSocketPath $ dir P.</> hostport2socket host port) >>= return . \case
Nothing -> (Nothing, [])
Just socketfile ->
- let socketfile' = fromRawFilePath socketfile
- in (Just socketfile', sshConnectionCachingParams socketfile')
+ (Just socketfile
+ , sshConnectionCachingParams (fromRawFilePath socketfile)
+ )
-- No connection caching with concurrency is not a good
-- combination, so warn the user.
go (Left whynocaching) = do
- Locks the socket lock file to prevent other git-annex processes from
- stopping the ssh multiplexer on this socket.
-}
-prepSocket :: FilePath -> SshHost -> [CommandParam] -> Annex ()
+prepSocket :: RawFilePath -> SshHost -> [CommandParam] -> Annex ()
prepSocket socketfile sshhost sshparams = do
-- There could be stale ssh connections hanging around
-- from a previous git-annex run that was interrupted.
- and this check makes such files be skipped since the corresponding lock
- file won't exist.
-}
-enumSocketFiles :: Annex [FilePath]
+enumSocketFiles :: Annex [RawFilePath]
enumSocketFiles = liftIO . go =<< sshCacheDir
where
go Nothing = return []
go (Just dir) = filterM (R.doesPathExist . socket2lock)
=<< filter (not . isLock)
- <$> catchDefaultIO [] (dirContents (fromRawFilePath dir))
+ <$> catchDefaultIO [] (dirContents dir)
{- Stop any unused ssh connection caching processes. -}
sshCleanup :: Annex ()
forceSshCleanup :: Annex ()
forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles
-forceStopSsh :: FilePath -> Annex ()
+forceStopSsh :: RawFilePath -> Annex ()
forceStopSsh socketfile = withNullHandle $ \nullh -> do
- let (dir, base) = splitFileName socketfile
+ let (dir, base) = splitFileName (fromRawFilePath socketfile)
let p = (proc "ssh" $ toCommand $
[ Param "-O", Param "stop" ] ++
sshConnectionCachingParams base ++
}
void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid ->
forceSuccessProcess p pid
- liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath socketfile)
+ liftIO $ removeWhenExistsWith R.removeLink socketfile
{- This needs to be as short as possible, due to limitations on the length
- of the path to a socket file. At the same time, it needs to be unique
where
lengthofmd5s = 32
-socket2lock :: FilePath -> RawFilePath
-socket2lock socket = toRawFilePath (socket ++ lockExt)
+socket2lock :: RawFilePath -> RawFilePath
+socket2lock socket = socket <> lockExt
-isLock :: FilePath -> Bool
-isLock f = lockExt `isSuffixOf` f
+isLock :: RawFilePath -> Bool
+isLock f = lockExt `S.isSuffixOf` f
-lockExt :: String
+lockExt :: S.ByteString
lockExt = ".lock"
{- This is the size of the sun_path component of sockaddr_un, which
void $ tryIO $ tryExclusiveLock tmplck $ do
tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir
void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir
- oldtmp <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDirOld
+ oldtmp <- fromRepo gitAnnexTmpOtherDirOld
liftIO $ mapM_ cleanold
=<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp)
- liftIO $ void $ tryIO $ removeDirectory oldtmp -- when empty
+ -- remove when empty
+ liftIO $ void $ tryIO $
+ removeDirectory (fromRawFilePath oldtmp)
where
cleanold f = do
now <- liftIO getPOSIXTime
let oldenough = now - (60 * 60 * 24 * 7)
- catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus (toRawFilePath f)) >>= \case
+ catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus f) >>= \case
Just mtime | realToFrac mtime <= oldenough ->
- void $ tryIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
+ void $ tryIO $ removeWhenExistsWith R.removeLink f
_ -> return ()
import Utility.TimeStamp
import Data.ByteString.Builder
+import qualified Data.ByteString as B
import qualified Data.Attoparsec.ByteString.Lazy as A
currentVectorClock :: Annex CandidateVectorClock
buildVectorClock :: VectorClock -> Builder
buildVectorClock = string7 . formatVectorClock
-parseVectorClock :: String -> Maybe VectorClock
+parseVectorClock :: B.ByteString -> Maybe VectorClock
parseVectorClock t = VectorClock <$> parsePOSIXTime t
vectorClockParser :: A.Parser VectorClock
import Types.VectorClock
import Utility.Env
import Utility.TimeStamp
+import Utility.FileSystemEncoding
startVectorClock :: IO (IO CandidateVectorClock)
startVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK"
where
go Nothing = timebased
- go (Just s) = case parsePOSIXTime s of
+ go (Just s) = case parsePOSIXTime (encodeBS s) of
Just t -> return (pure (CandidateVectorClock t))
Nothing -> timebased
-- Avoid using fractional seconds in the CandidateVectorClock.
import Utility.Tmp
import Messages.Progress
import Logs.Transfer
+import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import Network.URI
import Control.Concurrent.Async
import Data.Either
import qualified Data.Aeson as Aeson
import GHC.Generics
-import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
-- youtube-dl can follow redirects to anywhere, including potentially
| isytdlp cmd = liftIO $
(nub . lines <$> readFile filelistfile)
`catchIO` (pure . const [])
- | otherwise = workdirfiles
- workdirfiles = liftIO $ filter (/= filelistfile)
- <$> (filterM (doesFileExist) =<< dirContents workdir)
+ | otherwise = map fromRawFilePath <$> workdirfiles
+ workdirfiles = liftIO $ filter (/= toRawFilePath filelistfile)
+ <$> (filterM R.doesPathExist =<< dirContents (toRawFilePath workdir))
filelistfile = workdir </> filelistfilebase
filelistfilebase = "git-annex-file-list-file"
isytdlp cmd = cmd == "yt-dlp"
Just have -> do
inprogress <- sizeOfDownloadsInProgress (const True)
partial <- liftIO $ sum
- <$> (mapM (getFileSize . toRawFilePath) =<< dirContents workdir)
+ <$> (mapM getFileSize =<< dirContents (toRawFilePath workdir))
reserve <- annexDiskReserve <$> Annex.getGitConfig
let maxsize = have - reserve - inprogress + partial
if maxsize > 0
else return $ Left $ "Scraping needs yt-dlp, but git-annex has been configured to use " ++ cmd
youtubePlaylist' :: URLString -> String -> IO (Either String [YoutubePlaylistItem])
-youtubePlaylist' url cmd = withTmpFile "yt-dlp" $ \tmpfile h -> do
+youtubePlaylist' url cmd = withTmpFile (toOsPath (toRawFilePath "yt-dlp")) $ \tmpfile h -> do
hClose h
(outerr, ok) <- processTranscript cmd
[ "--simulate"
, "--print-to-file"
-- Write json with selected fields.
, "%(.{" ++ intercalate "," youtubePlaylistItemFields ++ "})j"
- , tmpfile
+ , fromRawFilePath (fromOsPath tmpfile)
, url
]
Nothing
if ok
then flip catchIO (pure . Left . show) $ do
v <- map Aeson.eitherDecodeStrict . B8.lines
- <$> B.readFile tmpfile
+ <$> F.readFile' tmpfile
return $ case partitionEithers v of
((parserr:_), _) ->
Left $ "yt-dlp json parse error: " ++ parserr
import qualified Types.Remote as Remote
import Config.DynamicConfig
import Annex.SpecialRemote.Config
+import qualified Utility.FileIO as F
import Control.Concurrent.STM
import System.Posix.Types
- and parts of it are not relevant. -}
writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
writeDaemonStatusFile file status =
- viaTmp writeFile file =<< serialized <$> getPOSIXTime
+ viaTmp F.writeFile' (toOsPath (toRawFilePath file)) =<< serialized <$> getPOSIXTime
where
- serialized now = unlines
+ serialized now = encodeBS $ unlines
[ "lastRunning:" ++ show now
, "scanComplete:" ++ show (scanComplete status)
, "sanityCheckRunning:" ++ show (sanityCheckRunning status)
where
parse status = foldr parseline status . lines
parseline line status
- | key == "lastRunning" = parseval parsePOSIXTime $ \v ->
+ | key == "lastRunning" = parseval (parsePOSIXTime . encodeBS) $ \v ->
status { lastRunning = Just v }
| key == "scanComplete" = parseval readish $ \v ->
status { scanComplete = v }
| key == "sanityCheckRunning" = parseval readish $ \v ->
status { sanityCheckRunning = v }
- | key == "lastSanityCheck" = parseval parsePOSIXTime $ \v ->
+ | key == "lastSanityCheck" = parseval (parsePOSIXTime . encodeBS) $ \v ->
status { lastSanityCheck = Just v }
| otherwise = status -- unparsable line
where
import Utility.Tmp
import Utility.Env
import Utility.SshConfig
+import qualified Utility.FileIO as F
#ifdef darwin_HOST_OS
import Utility.OSX
#endif
import System.PosixCompat.Files (ownerExecuteMode)
+import qualified Data.ByteString.Char8 as S8
standaloneAppBase :: IO (Maybe FilePath)
standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
let runshell var = "exec " ++ base </> "runshell " ++ var
let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""
- installWrapper (sshdir </> "git-annex-shell") $ unlines
+ installWrapper (toRawFilePath (sshdir </> "git-annex-shell")) $
[ shebang
, "set -e"
, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
, rungitannexshell "$@"
, "fi"
]
- installWrapper (sshdir </> "git-annex-wrapper") $ unlines
+ installWrapper (toRawFilePath (sshdir </> "git-annex-wrapper")) $
[ shebang
, "set -e"
, runshell "\"$@\""
installFileManagerHooks program
-installWrapper :: FilePath -> String -> IO ()
+installWrapper :: RawFilePath -> [String] -> IO ()
installWrapper file content = do
- curr <- catchDefaultIO "" $ readFileStrict file
- when (curr /= content) $ do
- createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath file)))
- viaTmp writeFile file content
- modifyFileMode (toRawFilePath file) $
- addModes [ownerExecuteMode]
+ let content' = map encodeBS content
+ curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' (toOsPath file)
+ when (curr /= content') $ do
+ createDirectoryIfMissing True (fromRawFilePath (parentDir file))
+ viaTmp F.writeFile' (toOsPath file) $
+ linesFile' (S8.unlines content')
+ modifyFileMode file $ addModes [ownerExecuteMode]
installFileManagerHooks :: FilePath -> IO ()
#ifdef linux_HOST_OS
(kdeDesktopFile actions)
where
genNautilusScript scriptdir action =
- installscript (scriptdir </> scriptname action) $ unlines
+ installscript (toRawFilePath (scriptdir </> scriptname action)) $ unlines
[ shebang
, autoaddedcomment
, "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\""
]
scriptname action = "git-annex " ++ action
installscript f c = whenM (safetoinstallscript f) $ do
- writeFile f c
- modifyFileMode (toRawFilePath f) $ addModes [ownerExecuteMode]
+ writeFile (fromRawFilePath f) c
+ modifyFileMode f $ addModes [ownerExecuteMode]
safetoinstallscript f = catchDefaultIO True $
- elem autoaddedcomment . lines <$> readFileStrict f
+ elem (encodeBS autoaddedcomment) . fileLines'
+ <$> F.readFile' (toOsPath f)
autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)"
autoaddedmsg = "Automatically added by git-annex, do not edit."
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Assistant.Repair where
import qualified Utility.RawFilePath as R
import Control.Concurrent.Async
+import qualified Data.ByteString as S
+import qualified System.FilePath.ByteString as P
{- When the FsckResults require a repair, tries to do a non-destructive
- repair. If that fails, pops up an alert. -}
repairStaleLocks lockfiles
return $ not $ null lockfiles
where
- findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator (fromRawFilePath annexDir)) True . fromRawFilePath . Git.localGitDir
+ findgitfiles = dirContentsRecursiveSkipping (== P.dropTrailingPathSeparator annexDir) True . Git.localGitDir
islock f
- | "gc.pid" `isInfixOf` f = False
- | ".lock" `isSuffixOf` f = True
- | takeFileName f == "MERGE_HEAD" = True
+ | "gc.pid" `S.isInfixOf` f = False
+ | ".lock" `S.isSuffixOf` f = True
+ | P.takeFileName f == "MERGE_HEAD" = True
| otherwise = False
-repairStaleLocks :: [FilePath] -> Assistant ()
+repairStaleLocks :: [RawFilePath] -> Assistant ()
repairStaleLocks lockfiles = go =<< getsizes
where
getsize lf = catchMaybeIO $ (\s -> (lf, s))
- <$> getFileSize (toRawFilePath lf)
+ <$> getFileSize lf
getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
go [] = return ()
- go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l))
+ go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromRawFilePath . fst) l))
( do
waitforit "to check stale git lock file"
l' <- getsizes
if l' == l
- then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath . fst) l
+ then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . fst) l
else go l'
, do
waitforit "for git lock file writer"
import Git.Remote
import Utility.SshHost
import Utility.Process.Transcript
+import qualified Utility.FileIO as F
import Data.Text (Text)
import qualified Data.Text as T
removeAuthorizedKeys gitannexshellonly dir pubkey = do
let keyline = authorizedKeysLine gitannexshellonly dir pubkey
sshdir <- sshDir
- let keyfile = sshdir </> "authorized_keys"
- tryWhenExists (lines <$> readFileStrict keyfile) >>= \case
+ let keyfile = toOsPath $ toRawFilePath $ sshdir </> "authorized_keys"
+ tryWhenExists (map decodeBS . fileLines' <$> F.readFile' keyfile) >>= \case
Just ls -> viaTmp writeSshConfig keyfile $
unlines $ filter (/= keyline) ls
Nothing -> noop
{- Generates a ssh key pair. -}
genSshKeyPair :: IO SshKeyPair
-genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
+genSshKeyPair = withTmpDir (toOsPath (toRawFilePath "git-annex-keygen")) $ \dir -> do
ok <- boolSystem "ssh-keygen"
[ Param "-P", Param "" -- no password
, Param "-f", File $ dir </> "key"
| otherwise = do
let (f, _, _) = transferFileAndLockFile t g
mi <- liftIO $ catchDefaultIO Nothing $
- readTransferInfoFile Nothing (fromRawFilePath f)
+ readTransferInfoFile Nothing f
maybe noop (newsize t info . bytesComplete) mi
newsize t info sz
{- Called when a new transfer information file is written. -}
onAdd :: Handler
-onAdd file = case parseTransferFile file of
+onAdd file = case parseTransferFile (toRawFilePath file) of
Nothing -> noop
Just t -> go t =<< liftAnnex (checkTransfer t)
where
- The only thing that should change in the transfer info is the
- bytesComplete, so that's the only thing updated in the DaemonStatus. -}
onModify :: Handler
-onModify file = case parseTransferFile file of
+onModify file = case parseTransferFile (toRawFilePath file) of
Nothing -> noop
- Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
+ Just t -> go t =<< liftIO (readTransferInfoFile Nothing (toRawFilePath file))
where
go _ Nothing = noop
go t (Just newinfo) = alterTransferInfo t $
{- Called when a transfer information file is removed. -}
onDel :: Handler
-onDel file = case parseTransferFile file of
+onDel file = case parseTransferFile (toRawFilePath file) of
Nothing -> noop
Just t -> do
debug [ "transfer finishing:", show t]
if linktarget == Just link
then ensurestaged (Just link) =<< getDaemonStatus
else do
- liftAnnex $ replaceWorkTreeFile file $
+ liftAnnex $ replaceWorkTreeFile (toRawFilePath file) $
makeAnnexLink link
addLink file link (Just key)
-- other symlink, not git-annex
, return app
)
runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex
- then withTmpFile "webapp.html" $ \tmpfile h -> do
+ then withTmpFile (toOsPath "webapp.html") $ \tmpfile h -> do
hClose h
- go tlssettings addr webapp tmpfile Nothing
+ go tlssettings addr webapp (fromRawFilePath (fromOsPath tmpfile)) Nothing
else do
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
import qualified Annex.Url as Url hiding (download)
import Utility.Tuple
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import Data.Either
import qualified Data.Map as M
+import qualified System.FilePath.ByteString as P
{- Upgrade without interaction in the webapp. -}
unattendedUpgrade :: Assistant ()
{- OS X uses a dmg, so mount it, and copy the contents into place. -}
unpack = liftIO $ do
olddir <- oldVersionLocation
- withTmpDirIn (fromRawFilePath (parentDir (toRawFilePath newdir))) "git-annex.upgrade" $ \tmpdir -> do
+ withTmpDirIn (fromRawFilePath (parentDir (toRawFilePath newdir))) (toOsPath (toRawFilePath "git-annex.upgrade")) $ \tmpdir -> do
void $ boolSystem "hdiutil"
[ Param "attach", File distributionfile
, Param "-mountpoint", File tmpdir
- into place. -}
unpack = liftIO $ do
olddir <- oldVersionLocation
- withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) "git-annex.upgrade" $ \tmpdir -> do
+ withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) (toOsPath $ toRawFilePath "git-annex.upgrade") $ \tmpdir -> do
let tarball = tmpdir </> "tar"
-- Cannot rely on filename extension, and this also
-- avoids problems if tar doesn't support transparent
makeorigsymlink olddir
return (newdir </> "git-annex", deleteold)
installby a dstdir srcdir =
- mapM_ (\x -> a (toRawFilePath x) (toRawFilePath (dstdir </> takeFileName x)))
- =<< dirContents srcdir
+ mapM_ (\x -> a x (toRawFilePath dstdir P.</> P.takeFileName x))
+ =<< dirContents (toRawFilePath srcdir)
#endif
sanitycheck dir =
unlessM (doesDirectoryExist dir) $
fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs
removeWhenExistsWith R.removeLink (toRawFilePath manifest)
- removeEmptyRecursive dir
+ removeEmptyRecursive (toRawFilePath dir)
where
manifest = dir </> "git-annex.MANIFEST"
-removeEmptyRecursive :: FilePath -> IO ()
+removeEmptyRecursive :: RawFilePath -> IO ()
removeEmptyRecursive dir = do
mapM_ removeEmptyRecursive =<< dirContents dir
- void $ tryIO $ removeDirectory dir
+ void $ tryIO $ removeDirectory (fromRawFilePath dir)
{- This is a file that the UpgradeWatcher can watch for modifications to
- detect when git-annex has been upgraded.
downloadDistributionInfo = do
uo <- liftAnnex Url.getUrlOptions
gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
- liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do
+ liftIO $ withTmpDir (toOsPath (toRawFilePath "git-annex.tmp")) $ \tmpdir -> do
let infof = tmpdir </> "info"
let sigf = infof ++ ".sig"
ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo
<&&> (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoSigUrl sigf uo)
<&&> verifyDistributionSig gpgcmd sigf)
- ( parseInfoFile <$> readFileStrict infof
+ ( parseInfoFile . map decodeBS . fileLines'
+ <$> F.readFile' (toOsPath (toRawFilePath infof))
, return Nothing
)
verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool
verifyDistributionSig gpgcmd sig = readProgramFile >>= \case
Just p | isAbsolute p ->
- withUmask 0o0077 $ withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do
+ withUmask 0o0077 $ withTmpDir (toOsPath (toRawFilePath "git-annex-gpg.tmp")) $ \gpgtmp -> do
let trustedkeys = takeDirectory p </> "trustedkeys.gpg"
boolGpgCmd gpgcmd
[ Param "--no-default-keyring"
rs <- syncRemotes <$> getDaemonStatus
mapM_ (\r -> changeSyncable (Just r) False) rs
- liftAnnex $ prepareRemoveAnnexDir dir
+ liftAnnex $ prepareRemoveAnnexDir (toRawFilePath dir)
liftIO $ removeDirectoryRecursive . fromRawFilePath
=<< absPath (toRawFilePath dir)
v <- getCachedCred login
liftIO $ case v of
Nothing -> go [passwordprompts 0] Nothing
- Just pass -> withTmpFile "ssh" $ \passfile h -> do
+ Just pass -> withTmpFile (toOsPath "ssh") $ \passfile h -> do
hClose h
- writeFileProtected (toRawFilePath passfile) pass
+ writeFileProtected (fromOsPath passfile) pass
environ <- getEnvironment
let environ' = addEntries
[ ("SSH_ASKPASS", program)
- , (sshAskPassEnv, passfile)
+ , (sshAskPassEnv, fromRawFilePath $ fromOsPath passfile)
, ("DISPLAY", ":0")
] environ
go [passwordprompts 1] (Just environ')
genKeyName :: String -> S.ShortByteString
genKeyName s
-- Avoid making keys longer than the length of a SHA256 checksum.
- | bytelen > sha256len = S.toShort $ encodeBS $
- truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++
- show (md5 bl)
- | otherwise = S.toShort $ encodeBS s'
+ | bytelen > sha256len = S.toShort $
+ truncateFilePath (sha256len - md5len - 1) s'
+ <> "-" <> encodeBS (show (md5 bl))
+ | otherwise = S.toShort s'
where
- s' = preSanitizeKeyName s
+ s' = encodeBS $ preSanitizeKeyName s
bl = encodeBL s
bytelen = fromIntegral $ L.length bl
import Utility.FileMode
import Utility.CopyFile
import Utility.FileSystemEncoding
+import Utility.SystemDirectory
mklibs :: FilePath -> a -> IO Bool
mklibs top _installedbins = do
- fs <- dirContentsRecursive top
- exes <- filterM checkExe fs
+ fs <- dirContentsRecursive (toRawFilePath top)
+ exes <- filterM checkExe (map fromRawFilePath fs)
libs <- runLdd exes
glibclibs <- glibcLibs
forM_ fs $ \f -> do
let src = inTop top (x </> f)
let dst = inTop top (d </> f)
- unless (dirCruft f) $
+ unless (dirCruft (toRawFilePath f)) $
unlessM (doesDirectoryExist src) $
renameFile src dst
symlinkHwCapDirs top d
import Utility.Directory
import Utility.Env
import Utility.FileSystemEncoding
+import Utility.SystemDirectory
import Build.BundledPrograms
#ifdef darwin_HOST_OS
import System.IO
-- install git-core programs; these are run by the git command
createDirectoryIfMissing True gitcoredestdir
execpath <- getgitpath "exec-path"
- cfs <- dirContents execpath
+ cfs <- dirContents (toRawFilePath execpath)
forM_ cfs $ \f -> do
+ let f' = fromRawFilePath f
destf <- ((gitcoredestdir </>) . fromRawFilePath)
<$> relPathDirToFile
(toRawFilePath execpath)
- (toRawFilePath f)
+ f
createDirectoryIfMissing True (takeDirectory destf)
- issymlink <- isSymbolicLink <$> getSymbolicLinkStatus f
+ issymlink <- isSymbolicLink <$> getSymbolicLinkStatus f'
if issymlink
then do
-- many git-core files may symlink to eg
-- Other git-core files symlink to a file
-- beside them in the directory. Those
-- links can be copied as-is.
- linktarget <- readSymbolicLink f
+ linktarget <- readSymbolicLink f'
if takeFileName linktarget == linktarget
- then cp f destf
+ then cp f' destf
else do
let linktarget' = progDir topdir </> takeFileName linktarget
unlessM (doesFileExist linktarget') $ do
createDirectoryIfMissing True (takeDirectory linktarget')
- L.readFile f >>= L.writeFile linktarget'
+ L.readFile f' >>= L.writeFile linktarget'
removeWhenExistsWith removeLink destf
rellinktarget <- relPathDirToFile
(toRawFilePath (takeDirectory destf))
(toRawFilePath linktarget')
createSymbolicLink (fromRawFilePath rellinktarget) destf
- else cp f destf
+ else cp f' destf
-- install git's template files
-- git does not have an option to get the path of these,
-- next to the --man-path, in eg /usr/share/git-core
manpath <- getgitpath "man-path"
let templatepath = manpath </> ".." </> "git-core" </> "templates"
- tfs <- dirContents templatepath
+ tfs <- dirContents (toRawFilePath templatepath)
forM_ tfs $ \f -> do
destf <- ((templatedestdir </>) . fromRawFilePath)
<$> relPathDirToFile
(toRawFilePath templatepath)
- (toRawFilePath f)
+ f
createDirectoryIfMissing True (takeDirectory destf)
- cp f destf
+ cp (fromRawFilePath f) destf
where
gitcoredestdir = topdir </> "git-core"
templatedestdir = topdir </> "templates"
{- Package version determination. -}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Build.Version where
import Utility.Monad
import Utility.Exception
-import Utility.Misc
+import Utility.OsPath
+import Utility.FileSystemEncoding
+import qualified Utility.FileIO as F
type Version = String
middle = drop 1 . init
writeVersion :: Version -> IO ()
-writeVersion ver = catchMaybeIO (readFileStrict f) >>= \case
+writeVersion ver = catchMaybeIO (F.readFile' f) >>= \case
Just s | s == body -> return ()
- _ -> writeFile f body
+ _ -> F.writeFile' f body
where
- body = unlines $ concat
+ body = encodeBS $ unlines $ concat
[ header
, ["packageversion :: String"]
, ["packageversion = \"" ++ ver ++ "\""]
, ""
]
footer = []
- f = "Build/Version"
+ f = toOsPath "Build/Version"
* Support help.autocorrect settings "prompt", "never", and "immediate".
* Allow setting remote.foo.annex-tracking-branch to a branch name
that contains "/", as long as it's not a remote tracking branch.
+ * Added OsPath build flag, which speeds up git-annex's operations on files.
-- Joey Hess <id@joeyh.name> Mon, 20 Jan 2025 10:24:51 -0400
import Utility.Env
import Utility.Metered
import Utility.FileMode
+import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import Network.URI
import Data.Either
import qualified Data.ByteString.Char8 as B8
import qualified Data.Map.Strict as M
import qualified System.FilePath.ByteString as P
-import qualified Utility.RawFilePath as R
import qualified Data.Set as S
run :: [String] -> IO ()
resolveSpecialRemoteWebUrl url
| "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl =
Url.withUrlOptionsPromptingCreds $ \uo ->
- withTmpFile "git-remote-annex" $ \tmp h -> do
+ withTmpFile (toOsPath "git-remote-annex") $ \tmp h -> do
liftIO $ hClose h
- Url.download' nullMeterUpdate Nothing url tmp uo >>= \case
+ let tmp' = fromRawFilePath $ fromOsPath tmp
+ Url.download' nullMeterUpdate Nothing url tmp' uo >>= \case
Left err -> giveup $ url ++ " " ++ err
Right () -> liftIO $
- (headMaybe . lines)
- <$> readFileStrict tmp
+ fmap decodeBS
+ . headMaybe
+ . fileLines'
+ <$> F.readFile' tmp
| otherwise = return Nothing
where
lcurl = map toLower url
-- it needs to re-download it fresh every time, and the object
-- file should not be stored locally.
gettotmp dl = withOtherTmp $ \othertmp ->
- withTmpFileIn (fromRawFilePath othertmp) "GITMANIFEST" $ \tmp tmph -> do
+ withTmpFileIn (toOsPath othertmp) (toOsPath "GITMANIFEST") $ \tmp tmph -> do
liftIO $ hClose tmph
- _ <- dl tmp
- b <- liftIO (B.readFile tmp)
+ _ <- dl (fromRawFilePath (fromOsPath tmp))
+ b <- liftIO (F.readFile' tmp)
case parseManifest b of
Right m -> Just <$> verifyManifest rmt m
Left err -> giveup err
dropKey' rmt mk
put mk
- put mk = withTmpFile "GITMANIFEST" $ \tmp tmph -> do
+ put mk = withTmpFile (toOsPath "GITMANIFEST") $ \tmp tmph -> do
liftIO $ B8.hPut tmph (formatManifest manifest)
liftIO $ hClose tmph
-- Uploading needs the key to be in the annex objects
-- keys, which it is not.
objfile <- calcRepo (gitAnnexLocation mk)
modifyContentDir objfile $
- linkOrCopy mk (toRawFilePath tmp) objfile Nothing >>= \case
+ linkOrCopy mk (fromOsPath tmp) objfile Nothing >>= \case
-- Important to set the right perms even
-- though the object is only present
-- briefly, since sending objects may rely
f <- fromRepo (lastPushedManifestFile (Remote.uuid rmt))
oldmanifest <- liftIO $
fromRight mempty . parseManifest
- <$> B.readFile (fromRawFilePath f)
+ <$> F.readFile' (toOsPath f)
`catchNonAsync` (const (pure mempty))
let oldmanifest' = mkManifest [] $
S.fromList (inManifest oldmanifest)
-> Manifest
-> Annex (Key, Annex ())
generateGitBundle rmt bs manifest =
- withTmpFile "GITBUNDLE" $ \tmp tmph -> do
+ withTmpFile (toOsPath "GITBUNDLE") $ \tmp tmph -> do
+ let tmp' = fromOsPath tmp
liftIO $ hClose tmph
- inRepo $ Git.Bundle.create tmp bs
+ inRepo $ Git.Bundle.create (fromRawFilePath tmp') bs
bundlekey <- genGitBundleKey (Remote.uuid rmt)
- (toRawFilePath tmp) nullMeterUpdate
+ tmp' nullMeterUpdate
if (bundlekey `notElem` inManifest manifest)
then do
- unlessM (moveAnnex bundlekey (AssociatedFile Nothing) (toRawFilePath tmp)) $
+ unlessM (moveAnnex bundlekey (AssociatedFile Nothing) tmp') $
giveup "Unable to push"
return (bundlekey, uploadaction bundlekey)
else return (bundlekey, noop)
-- journal writes to a temporary directory, so that all writes
-- to the git-annex branch by the action will be discarded.
specialRemoteFromUrl :: StartAnnexBranch -> Annex a -> Annex a
-specialRemoteFromUrl sab a = withTmpDir "journal" $ \tmpdir -> do
+specialRemoteFromUrl sab a = withTmpDir (toOsPath "journal") $ \tmpdir -> do
Annex.overrideGitConfig $ \c ->
c { annexAlwaysCommit = False }
Annex.BranchState.changeState $ \st ->
-- objects are deleted.
cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex ()
cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do
- liftIO $ mapM_ removeFile =<< dirContents alternatejournaldir
+ liftIO $ mapM_ R.removeLink
+ =<< dirContents (toRawFilePath alternatejournaldir)
case sab of
AnnexBranchExistedAlready _ -> noop
AnnexBranchCreatedEmpty r ->
import Data.Time.Clock.POSIX
import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID)
import qualified System.FilePath.ByteString as P
+import qualified Data.ByteString as S
data AnnexedFileSeeker = AnnexedFileSeeker
{ startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart
-- exist.
get p = ifM (isDirectory <$> R.getFileStatus p')
( map (\f ->
- let f' = toRawFilePath f
- in (f', P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f'))
- <$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) False p
+ (f, P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f))
+ <$> dirContentsRecursiveSkipping (".git" `S.isSuffixOf`) False p'
, return [(p', P.takeFileName p')]
)
where
startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> FilePath -> URLString -> Maybe Integer -> CommandStart
startRemote addunlockedmatcher r o si file uri sz = do
pathmax <- liftIO $ fileNameLengthLimit "."
- let file' = joinPath $ map (truncateFilePath pathmax) $
- splitDirectories file
+ let file' = P.joinPath $ map (truncateFilePath pathmax) $
+ P.splitDirectories (toRawFilePath file)
startingAddUrl si uri o $ do
showNote $ UnquotedString $ "from " ++ Remote.name r
- showDestinationFile (toRawFilePath file')
- performRemote addunlockedmatcher r o uri (toRawFilePath file') sz
+ showDestinationFile file'
+ performRemote addunlockedmatcher r o uri file' sz
performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> RawFilePath -> Maybe Integer -> CommandPerform
performRemote addunlockedmatcher r o uri file sz = lookupKey file >>= \case
return f
| otherwise = do
pathmax <- liftIO $ fileNameLengthLimit "."
- return $ truncateFilePath pathmax $ sanitizeFilePath f
+ return $ fromRawFilePath $ truncateFilePath pathmax $
+ toRawFilePath $ sanitizeFilePath f
-- sanitizeFilePath avoids all these security problems
-- (and probably others, but at least this catches the most egrarious ones).
urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing (verifiableOption o)
downloader f p = Url.withUrlOptions $ downloadUrl False urlkey p Nothing [url] f
go Nothing = return Nothing
- go (Just (tmp, backend)) = ifM (useYoutubeDl o <&&> liftIO (isHtmlFile (fromRawFilePath tmp)))
+ go (Just (tmp, backend)) = ifM (useYoutubeDl o <&&> liftIO (isHtmlFile tmp))
( tryyoutubedl tmp backend
, normalfinish tmp backend
)
url2file :: URI -> Maybe Int -> Int -> FilePath
url2file url pathdepth pathmax = case pathdepth of
- Nothing -> truncateFilePath pathmax $ sanitizeFilePath fullurl
- Just depth
+ Nothing -> truncatesanitize fullurl
+ Just depth
| depth >= length urlbits -> frombits id
| depth > 0 -> frombits $ drop depth
| depth < 0 -> frombits $ reverse . take (negate depth) . reverse
, uriQuery url
]
frombits a = intercalate "/" $ a urlbits
- urlbits = map (truncateFilePath pathmax . sanitizeFilePath) $
+ urlbits = map truncatesanitize $
filter (not . null) $ splitc '/' fullurl
+ truncatesanitize = fromRawFilePath
+ . truncateFilePath pathmax
+ . toRawFilePath
+ . sanitizeFilePath
urlString2file :: URLString -> Maybe Int -> Int -> FilePath
urlString2file s pathdepth pathmax = case Url.parseURIRelaxed s of
sent <- tryNonAsync $ if not (isGitShaKey ek)
then tryrenameannexobject $ sendannexobject
-- Sending a non-annexed file.
- else withTmpFile "export" $ \tmp h -> do
+ else withTmpFile (toOsPath "export") $ \tmp h -> do
b <- catObject contentsha
liftIO $ L.hPut h b
liftIO $ hClose h
Remote.action $
- storer tmp ek loc nullMeterUpdate
+ storer (fromRawFilePath (fromOsPath tmp)) ek loc nullMeterUpdate
let failedsend = liftIO $ modifyMVar_ allfilledvar (pure . const (AllFilled False))
case sent of
Right True -> next $ cleanupExport r db ek loc True
breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform
breakHardLink file key obj = do
- replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
+ replaceWorkTreeFile file $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
unlessM (checkedCopyFile key obj tmp mode) $
giveup "unable to break hard link"
makeHardLink :: RawFilePath -> Key -> CommandPerform
makeHardLink file key = do
- replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
+ replaceWorkTreeFile file $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
linkFromAnnex' key tmp mode >>= \case
LinkAnnexFailed -> giveup "unable to make hard link"
mtime <- liftIO $ catchMaybeIO $ Posix.modificationTimeHiRes
<$> R.getSymbolicLinkStatus file
#endif
- replaceWorkTreeFile (fromRawFilePath file) $ \tmpfile -> do
+ replaceWorkTreeFile file $ \tmpfile -> do
liftIO $ R.createSymbolicLink link tmpfile
#if ! defined(mingw32_HOST_OS)
liftIO $ maybe noop (\t -> touch tmpfile t False) mtime
import Types.CleanupActions
import Types.Key
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import Data.Time.Clock.POSIX
import System.Posix.Types (EpochTime)
case mk of
Just k | k == key -> whenM (inAnnex key) $ do
showNote "fixing worktree content"
- replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
+ replaceWorkTreeFile file $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
ifM (annexThin <$> Annex.getGitConfig)
( void $ linkFromAnnex' key tmp mode
f <- fromRepo (gitAnnexFsckState u)
createAnnexDirectory $ parentDir f
liftIO $ removeWhenExistsWith R.removeLink f
- liftIO $ withFile (fromRawFilePath f) WriteMode $ \h -> do
+ liftIO $ F.withFile (toOsPath f) WriteMode $ \h -> do
#ifndef mingw32_HOST_OS
t <- modificationTime <$> R.getFileStatus f
#else
liftIO $ catchDefaultIO Nothing $ do
timestamp <- modificationTime <$> R.getFileStatus f
let fromstatus = Just (realToFrac timestamp)
- fromfile <- parsePOSIXTime <$> readFile (fromRawFilePath f)
+ fromfile <- parsePOSIXTime <$> F.readFile' (toOsPath f)
return $ if matchingtimestamp fromfile fromstatus
then Just timestamp
else Nothing
| scrapeOption o = scrape
| otherwise = get
- get = withTmpFile "feed" $ \tmpf h -> do
+ get = withTmpFile (toOsPath "feed") $ \tmpf h -> do
+ let tmpf' = fromRawFilePath $ fromOsPath tmpf
liftIO $ hClose h
- ifM (downloadFeed url tmpf)
- ( parse tmpf
+ ifM (downloadFeed url tmpf')
+ ( parse tmpf'
, do
recordfail
next $ feedProblem url
breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (R.getFileStatus obj)) $ do
mfc <- withTSDelta (liftIO . genInodeCache file)
unlessM (sameInodeCache obj (maybeToList mfc)) $ do
- modifyContentDir obj $ replaceGitAnnexDirFile (fromRawFilePath obj) $ \tmp -> do
+ modifyContentDir obj $ replaceGitAnnexDirFile obj $ \tmp -> do
unlessM (checkedCopyFile key obj tmp Nothing) $
giveup "unable to lock file"
Database.Keys.storeInodeCaches key [obj]
-- the names of keys, and would have to be copied, which is too
-- expensive.
starting "sending files" (ActionItemOther Nothing) (SeekInput []) $
- withTmpFile "send" $ \t h -> do
+ withTmpFile (toOsPath "send") $ \t h -> do
let ww = WarnUnmatchLsFiles "multicast"
(fs', cleanup) <- seekHelper id ww LsFiles.inRepo
=<< workTreeItems ww fs
-- only allow clients on the authlist
, Param "-H", Param ("@"++authlist)
-- pass in list of files to send
- , Param "-i", File t
+ , Param "-i", File (fromRawFilePath (fromOsPath t))
] ++ ups
liftIO (boolSystem "uftp" ps) >>= showEndResult
next $ return True
(callback, environ, statush) <- liftIO multicastCallbackEnv
tmpobjdir <- fromRepo gitAnnexTmpObjectDir
createAnnexDirectory tmpobjdir
- withTmpDirIn (fromRawFilePath tmpobjdir) "multicast" $ \tmpdir -> withAuthList $ \authlist -> do
+ withTmpDirIn (fromRawFilePath tmpobjdir) (toOsPath "multicast") $ \tmpdir -> withAuthList $ \authlist -> do
abstmpdir <- liftIO $ absPath (toRawFilePath tmpdir)
abscallback <- liftIO $ searchPath callback
let ps =
withAuthList :: (FilePath -> Annex a) -> Annex a
withAuthList a = do
m <- knownFingerPrints
- withTmpFile "authlist" $ \t h -> do
+ withTmpFile (toOsPath "authlist") $ \t h -> do
liftIO $ hPutStr h (genAuthList m)
liftIO $ hClose h
- a t
+ a (fromRawFilePath (fromOsPath t))
genAuthList :: M.Map UUID Fingerprint -> String
genAuthList = unlines . map fmt . M.toList
import Utility.ThreadScheduler
import Utility.SafeOutput
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import qualified Utility.MagicWormhole as Wormhole
import Control.Concurrent.Async
serializePairData (PairData (HalfAuthToken ha) addrs) = unlines $
T.unpack ha : map formatP2PAddress addrs
-deserializePairData :: String -> Maybe PairData
-deserializePairData s = case lines s of
- [] -> Nothing
- (ha:l) -> do
- addrs <- mapM unformatP2PAddress l
- return (PairData (HalfAuthToken (T.pack ha)) addrs)
+deserializePairData :: [String] -> Maybe PairData
+deserializePairData [] = Nothing
+deserializePairData (ha:l) = do
+ addrs <- mapM unformatP2PAddress l
+ return (PairData (HalfAuthToken (T.pack ha)) addrs)
data PairingResult
= PairSuccess
-- files. Permissions of received files may allow others
-- to read them. So, set up a temp directory that only
-- we can read.
- withTmpDir "pair" $ \tmp -> do
+ withTmpDir (toOsPath "pair") $ \tmp -> do
liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath tmp) $
removeModes otherGroupModes
let sendf = tmp </> "send"
then return ReceiveFailed
else do
r <- liftIO $ tryIO $
- readFileStrict recvf
+ map decodeBS . fileLines' <$> F.readFile'
+ (toOsPath (toRawFilePath recvf))
case r of
Left _e -> return ReceiveFailed
- Right s -> maybe
+ Right ls -> maybe
(return ReceiveFailed)
(finishPairing 100 remotename ourhalf)
- (deserializePairData s)
+ (deserializePairData ls)
-- | Allow the peer we're pairing with to authenticate to us,
-- using an authtoken constructed from the two HalfAuthTokens.
findRepos :: Options -> IO [Git.Repo]
findRepos o = do
- files <- map toRawFilePath . concat
- <$> mapM dirContents (directoryOption o)
+ files <- concat
+ <$> mapM (dirContents . toRawFilePath) (directoryOption o)
map Git.Construct.newFrom . catMaybes
<$> mapM Git.Construct.checkForRepo files
st <- liftIO $ R.getFileStatus file
when (linkCount st > 1) $ do
freezeContent oldobj
- replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
+ replaceWorkTreeFile file $ \tmp -> do
unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $
giveup "can't lock old key"
thawContent tmp
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Command.ResolveMerge where
import Command
import Git.Sha
import qualified Git.Branch
import Annex.AutoMerge
+import qualified Utility.FileIO as F
-import qualified Data.ByteString as S
+import qualified System.FilePath.ByteString as P
cmd :: Command
cmd = command "resolvemerge" SectionPlumbing
start :: CommandStart
start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do
us <- fromMaybe nobranch <$> inRepo Git.Branch.current
- d <- fromRawFilePath <$> fromRepo Git.localGitDir
- let merge_head = d </> "MERGE_HEAD"
+ d <- fromRepo Git.localGitDir
+ let merge_head = toOsPath $ d P.</> "MERGE_HEAD"
them <- fromMaybe (giveup nomergehead) . extractSha
- <$> liftIO (S.readFile merge_head)
+ <$> liftIO (F.readFile' merge_head)
ifM (resolveMerge (Just us) them False)
( do
void $ commitResolvedMerge Git.Branch.ManualCommit
import Remote.Helper.Chunked
import Remote.Helper.Encryptable (encryptionField, highRandomQualityField)
import Git.Types
+import qualified Utility.FileIO as F
import Test.Tasty
import Test.Tasty.Runners
get r k
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 0" $ \r k -> do
- tmp <- fromRawFilePath <$> prepTmp k
- liftIO $ writeFile tmp ""
+ tmp <- toOsPath <$> prepTmp k
+ liftIO $ F.writeFile' tmp mempty
lockContentForRemoval k noop removeAnnex
get r k
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 33%" $ \r k -> do
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
- tmp <- fromRawFilePath <$> prepTmp k
+ tmp <- toOsPath <$> prepTmp k
partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do
sz <- hFileSize h
L.hGet h $ fromInteger $ sz `div` 3
- liftIO $ L.writeFile tmp partial
+ liftIO $ F.writeFile tmp partial
lockContentForRemoval k noop removeAnnex
get r k
, check "fsck downloaded object" fsck
storeexport ea k = do
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
Remote.storeExport ea loc k testexportlocation nullMeterUpdate
- retrieveexport ea k = withTmpFile "exported" $ \tmp h -> do
+ retrieveexport ea k = withTmpFile (toOsPath "exported") $ \tmp h -> do
liftIO $ hClose h
- tryNonAsync (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) >>= \case
+ tryNonAsync (Remote.retrieveExport ea k testexportlocation (fromRawFilePath (fromOsPath tmp)) nullMeterUpdate) >>= \case
Left _ -> return False
- Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k (toRawFilePath tmp)
+ Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k (fromOsPath tmp)
checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation
removeexport ea k = Remote.removeExport ea k testexportlocation
removeexportdirectory ea = case Remote.removeExportDirectory ea of
| otherwise = sz > 0
randKey :: Int -> Annex Key
-randKey sz = withTmpFile "randkey" $ \f h -> do
+randKey sz = withTmpFile (toOsPath "randkey") $ \f h -> do
gen <- liftIO (newGenIO :: IO SystemRandom)
case genBytes sz gen of
Left e -> giveup $ "failed to generate random key: " ++ show e
Right (rand, _) -> liftIO $ B.hPut h rand
liftIO $ hClose h
let ks = KeySource
- { keyFilename = toRawFilePath f
- , contentLocation = toRawFilePath f
+ { keyFilename = fromOsPath f
+ , contentLocation = fromOsPath f
, inodeCache = Nothing
}
k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of
Just a -> a ks nullMeterUpdate
Nothing -> giveup "failed to generate random key (backend problem)"
- _ <- moveAnnex k (AssociatedFile Nothing) (toRawFilePath f)
+ _ <- moveAnnex k (AssociatedFile Nothing) (fromOsPath f)
return k
getReadonlyKey :: Remote -> RawFilePath -> Annex Key
removeAnnexDir :: CommandCleanup -> CommandStart
removeAnnexDir recordok = do
Annex.Queue.flush
- annexdir <- fromRawFilePath <$> fromRepo gitAnnexDir
+ annexdir <- fromRepo gitAnnexDir
annexobjectdir <- fromRepo gitAnnexObjectDir
starting ("uninit objects") (ActionItemOther Nothing) (SeekInput []) $ do
leftovers <- removeUnannexed =<< listKeys InAnnex
prepareRemoveAnnexDir annexdir
if null leftovers
then do
- liftIO $ removeDirectoryRecursive annexdir
+ liftIO $ removeDirectoryRecursive (fromRawFilePath annexdir)
next recordok
else giveup $ unlines
[ "Not fully uninitialized"
-
- Also closes sqlite databases that might be in the directory,
- to avoid later failure to write any cached changes to them. -}
-prepareRemoveAnnexDir :: FilePath -> Annex ()
+prepareRemoveAnnexDir :: RawFilePath -> Annex ()
prepareRemoveAnnexDir annexdir = do
Database.Keys.closeDb
liftIO $ prepareRemoveAnnexDir' annexdir
-prepareRemoveAnnexDir' :: FilePath -> IO ()
+prepareRemoveAnnexDir' :: RawFilePath -> IO ()
prepareRemoveAnnexDir' annexdir =
emptyWhenDoesNotExist (dirTreeRecursiveSkipping (const False) annexdir)
- >>= mapM_ (void . tryIO . allowWrite . toRawFilePath)
+ >>= mapM_ (void . tryIO . allowWrite)
{- Keys that were moved out of the annex have a hard link still in the
- annex, with > 1 link count, and those can be removed.
perform :: RawFilePath -> Key -> CommandPerform
perform dest key = do
destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus dest
- destic <- replaceWorkTreeFile (fromRawFilePath dest) $ \tmp -> do
+ destic <- replaceWorkTreeFile dest $ \tmp -> do
ifM (inAnnex key)
( do
r <- linkFromAnnex' key tmp destmode
import Git.Types (fromConfigKey, fromConfigValue)
import Utility.DataUnits
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
cmd :: Command
cmd = command "vicfg" SectionSetup "edit configuration in git-annex branch"
-- Allow EDITOR to be processed by the shell, so it can contain options.
unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $
giveup $ vi ++ " exited nonzero; aborting"
- r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrict f)
+ r <- liftIO $ parseCfg (defCfg curcfg)
+ . map decodeBS
+ . fileLines'
+ <$> F.readFile' (toOsPath (toRawFilePath f))
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
case r of
Left s -> do
{- If there's a parse error, returns a new version of the file,
- with the problem lines noted. -}
-parseCfg :: Cfg -> String -> Either String Cfg
-parseCfg defcfg = go [] defcfg . lines
+parseCfg :: Cfg -> [String] -> Either String Cfg
+parseCfg defcfg = go [] defcfg
where
go c cfg []
| null (mapMaybe fst c) = Right cfg
import Utility.Path as X
import Utility.Path.AbsRel as X
import Utility.Directory as X
+import Utility.SystemDirectory as X
import Utility.MoveFile as X
import Utility.Monad as X
import Utility.Data as X
import Utility.Network as X
import Utility.Split as X
import Utility.FileSystemEncoding as X
+import Utility.OsPath as X
import Utility.PartialPrelude as X
f <- autoStartFile
createDirectoryIfMissing True $
fromRawFilePath (parentDir (toRawFilePath f))
- viaTmp writeFile f $ unlines dirs'
+ viaTmp (writeFile . fromRawFilePath . fromOsPath)
+ (toOsPath (toRawFilePath f))
+ (unlines dirs')
{- Adds a directory to the autostart file. If the directory is already
- present, it's moved to the top, so it will be used as the default
import Config
import Utility.Directory.Create
import Annex.Version
+import qualified Utility.FileIO as F
+import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
configureSmudgeFilter :: Annex ()
lfs <- readattr lf
gfs <- readattr gf
gittop <- Git.localGitDir <$> gitRepo
- liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do
+ liftIO $ unless ("filter=annex" `S.isInfixOf` (lfs <> gfs)) $ do
createDirectoryUnder [gittop] (P.takeDirectory lf)
- writeFile (fromRawFilePath lf) (lfs ++ "\n" ++ unlines stdattr)
+ F.writeFile' (toOsPath lf) $
+ linesFile' (lfs <> encodeBS ("\n" ++ unlines stdattr))
where
- readattr = liftIO . catchDefaultIO "" . readFileStrict . fromRawFilePath
+ readattr = liftIO . catchDefaultIO mempty . F.readFile' . toOsPath
configureSmudgeFilterProcess :: Annex ()
configureSmudgeFilterProcess =
-- git-annex does not commit that.
deconfigureSmudgeFilter :: Annex ()
deconfigureSmudgeFilter = do
- lf <- fromRawFilePath <$> Annex.fromRepo Git.attributesLocal
- ls <- liftIO $ catchDefaultIO [] $ lines <$> readFileStrict lf
- liftIO $ writeFile lf $ unlines $
+ lf <- Annex.fromRepo Git.attributesLocal
+ ls <- liftIO $ catchDefaultIO [] $
+ map decodeBS . fileLines' <$> F.readFile' (toOsPath lf)
+ liftIO $ writeFile (fromRawFilePath lf) $ unlines $
filter (\l -> l `notElem` stdattr && not (null l)) ls
unsetConfig (ConfigKey "filter.annex.smudge")
unsetConfig (ConfigKey "filter.annex.clean")
import Utility.Env (getEnv)
import Utility.Base64
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
-import qualified Data.ByteString.Lazy.Char8 as L
-import qualified Data.ByteString.Char8 as S
+import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.ByteString.Char8 as S8
import qualified Data.Map as M
import qualified System.FilePath.ByteString as P
storeconfig creds key (Just cipher) = do
cmd <- gpgCmd <$> Annex.getGitConfig
s <- liftIO $ encrypt cmd (pc, gc) cipher
- (feedBytes $ L.pack $ encodeCredPair creds)
+ (feedBytes $ L8.pack $ encodeCredPair creds)
(readBytesStrictly return)
storeconfig' key (Accepted (decodeBS (toB64 s)))
storeconfig creds key Nothing =
fromenccreds enccreds cipher storablecipher = do
cmd <- gpgCmd <$> Annex.getGitConfig
mcreds <- liftIO $ catchMaybeIO $ decrypt cmd (c, gc) cipher
- (feedBytes $ L.fromStrict $ fromB64 enccreds)
- (readBytesStrictly $ return . S.unpack)
+ (feedBytes $ L8.fromStrict $ fromB64 enccreds)
+ (readBytesStrictly $ return . S8.unpack)
case mcreds of
Just creds -> fromcreds creds
Nothing -> do
liftIO $ writeFileProtected (d P.</> toRawFilePath file) creds
readCreds :: FilePath -> Annex (Maybe Creds)
-readCreds f = liftIO . catchMaybeIO . readFileStrict =<< credsFile f
+readCreds f = do
+ f' <- toOsPath . toRawFilePath <$> credsFile f
+ liftIO $ catchMaybeIO $ decodeBS . S8.unlines . fileLines'
+ <$> F.readFile' f'
credsFile :: FilePath -> Annex FilePath
credsFile basefile = do
Cipher{} ->
let passphrase = cipherPassphrase cipher
in case statelessOpenPGPCommand c of
- Just sopcmd -> withTmpDir "sop" $ \d ->
+ Just sopcmd -> withTmpDir (toOsPath "sop") $ \d ->
SOP.encryptSymmetric sopcmd passphrase
(SOP.EmptyDirectory d)
(statelessOpenPGPProfile c)
Cipher{} ->
let passphrase = cipherPassphrase cipher
in case statelessOpenPGPCommand c of
- Just sopcmd -> withTmpDir "sop" $ \d ->
+ Just sopcmd -> withTmpDir (toOsPath "sop") $ \d ->
SOP.decryptSymmetric sopcmd passphrase
(SOP.EmptyDirectory d)
feeder reader
benchmarkDbs :: CriterionMode -> Integer -> Annex ()
#ifdef WITH_BENCHMARK
-benchmarkDbs mode n = withTmpDirIn "." "benchmark" $ \tmpdir -> do
+benchmarkDbs mode n = withTmpDirIn "." (toOsPath "benchmark") $ \tmpdir -> do
db <- benchDb (toRawFilePath tmpdir) n
liftIO $ runMode mode
[ bgroup "keys database"
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
module Git.HashObject where
{- Injects a blob into git. Unfortunately, the current git-hash-object
- interface does not allow batch hashing without using temp files. -}
hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha
-hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do
+hashBlob h b = withTmpFile (toOsPath "hash") $ \tmp tmph -> do
hashableBlobToHandle tmph b
hClose tmph
- hashFile h (toRawFilePath tmp)
+ hashFile h (fromOsPath tmp)
{- Injects some content into git, returning its Sha.
-
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
module Git.Hook where
import Utility.Tmp
import Utility.Shell
import Utility.FileMode
+import qualified Utility.FileIO as F
#ifndef mingw32_HOST_OS
import qualified Utility.RawFilePath as R
import System.PosixCompat.Files (fileMode)
#endif
-import qualified Data.ByteString as B
+import qualified System.FilePath.ByteString as P
data Hook = Hook
- { hookName :: FilePath
+ { hookName :: RawFilePath
, hookScript :: String
, hookOldScripts :: [String]
}
instance Eq Hook where
a == b = hookName a == hookName b
-hookFile :: Hook -> Repo -> FilePath
-hookFile h r = fromRawFilePath (localGitDir r) </> "hooks" </> hookName h
+hookFile :: Hook -> Repo -> RawFilePath
+hookFile h r = localGitDir r P.</> "hooks" P.</> hookName h
{- Writes a hook. Returns False if the hook already exists with a different
- content. Upgrades old scripts.
- is run with a bundled bash, so should start with #!/bin/sh
-}
hookWrite :: Hook -> Repo -> IO Bool
-hookWrite h r = ifM (doesFileExist f)
+hookWrite h r = ifM (doesFileExist (fromRawFilePath f))
( expectedContent h r >>= \case
UnexpectedContent -> return False
ExpectedContent -> return True
where
f = hookFile h r
go = do
- -- On Windows, using B.writeFile here avoids
- -- the newline translation done by writeFile.
+ -- On Windows, using a ByteString as the file content
+ -- avoids the newline translation done by writeFile.
-- Hook scripts on Windows could use CRLF endings, but
-- they typically use unix newlines, which does work there
-- and makes the repository more portable.
- viaTmp B.writeFile f (encodeBS (hookScript h))
- void $ tryIO $ modifyFileMode
- (toRawFilePath f)
- (addModes executeModes)
+ viaTmp F.writeFile' (toOsPath f) (encodeBS (hookScript h))
+ void $ tryIO $ modifyFileMode f (addModes executeModes)
return True
{- Removes a hook. Returns False if the hook contained something else, and
, return True
)
where
- f = hookFile h r
+ f = fromRawFilePath $ hookFile h r
data ExpectedContent = UnexpectedContent | ExpectedContent | OldExpectedContent
-- and so a hook file that has CRLF will be treated the same as one
-- that has LF. That is intentional, since users may have a reason
-- to prefer one or the other.
- content <- readFile $ hookFile h r
+ content <- readFile $ fromRawFilePath $ hookFile h r
return $ if content == hookScript h
then ExpectedContent
else if any (content ==) (hookOldScripts h)
let f = hookFile h r
catchBoolIO $
#ifndef mingw32_HOST_OS
- isExecutable . fileMode <$> R.getFileStatus (toRawFilePath f)
+ isExecutable . fileMode <$> R.getFileStatus f
#else
- doesFileExist f
+ doesFileExist (fromRawFilePath f)
#endif
runHook :: (FilePath -> [CommandParam] -> IO a) -> Hook -> [CommandParam] -> Repo -> IO a
runHook runner h ps r = do
- let f = hookFile h r
+ let f = fromRawFilePath $ hookFile h r
(c, cps) <- findShellCommand f
runner c (cps ++ ps)
mkInodeCache
<$> (readish =<< M.lookup "ino:" m)
<*> (readish =<< M.lookup "size:" m)
- <*> (parsePOSIXTime =<< (replace ":" "." <$> M.lookup "mtime:" m))
+ <*> (parsePOSIXTime =<< (encodeBS . replace ":" "." <$> M.lookup "mtime:" m))
packIdxFile :: RawFilePath -> RawFilePath
packIdxFile = flip P.replaceExtension "idx"
-listPackFiles :: Repo -> IO [FilePath]
-listPackFiles r = filter (".pack" `isSuffixOf`)
- <$> catchDefaultIO [] (dirContents $ fromRawFilePath $ packDir r)
+listPackFiles :: Repo -> IO [RawFilePath]
+listPackFiles r = filter (".pack" `B.isSuffixOf`)
+ <$> catchDefaultIO [] (dirContents $ packDir r)
listLooseObjectShas :: Repo -> IO [Sha]
listLooseObjectShas r = catchDefaultIO [] $
- mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories)
- <$> emptyWhenDoesNotExist (dirContentsRecursiveSkipping (== "pack") True (fromRawFilePath (objectsDir r)))
+ mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories . decodeBS)
+ <$> emptyWhenDoesNotExist (dirContentsRecursiveSkipping (== "pack") True (objectsDir r))
looseObjectFile :: Repo -> Sha -> RawFilePath
looseObjectFile r sha = objectsDir r P.</> prefix P.</> rest
import Git.Sha
import Git.Types
import Git.FilePath
+import qualified Utility.FileIO as F
import Data.Char (chr, ord)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
+import qualified System.FilePath.ByteString as P
headRef :: Ref
headRef = Ref "HEAD"
-headFile :: Repo -> FilePath
-headFile r = fromRawFilePath (localGitDir r) </> "HEAD"
+headFile :: Repo -> RawFilePath
+headFile r = localGitDir r P.</> "HEAD"
setHeadRef :: Ref -> Repo -> IO ()
-setHeadRef ref r = S.writeFile (headFile r) ("ref: " <> fromRef' ref)
+setHeadRef ref r =
+ F.writeFile' (toOsPath (headFile r)) ("ref: " <> fromRef' ref)
{- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String
import Utility.Rsync
import Utility.FileMode
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import qualified Data.Set as S
+import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified System.FilePath.ByteString as P
explodePacks r = go =<< listPackFiles r
where
go [] = return False
- go packs = withTmpDir "packs" $ \tmpdir -> do
+ go packs = withTmpDir (toOsPath "packs") $ \tmpdir -> do
r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir
putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do
-- Just in case permissions are messed up.
- allowRead (toRawFilePath packfile)
+ allowRead packfile
-- May fail, if pack file is corrupt.
void $ tryIO $
pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
- L.hPut h =<< L.readFile packfile
- objs <- emptyWhenDoesNotExist (dirContentsRecursive tmpdir)
+ L.hPut h =<< F.readFile (toOsPath packfile)
+ objs <- emptyWhenDoesNotExist (dirContentsRecursive (toRawFilePath tmpdir))
forM_ objs $ \objfile -> do
f <- relPathDirToFile
(toRawFilePath tmpdir)
- (toRawFilePath objfile)
+ objfile
let dest = objectsDir r P.</> f
createDirectoryIfMissing True
(fromRawFilePath (parentDir dest))
- moveFile (toRawFilePath objfile) dest
+ moveFile objfile dest
forM_ packs $ \packfile -> do
- let f = toRawFilePath packfile
- removeWhenExistsWith R.removeLink f
- removeWhenExistsWith R.removeLink (packIdxFile f)
+ removeWhenExistsWith R.removeLink packfile
+ removeWhenExistsWith R.removeLink (packIdxFile packfile)
return True
{- Try to retrieve a set of missing objects, from the remotes of a
retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults
retrieveMissingObjects missing referencerepo r
| not (foundBroken missing) = return missing
- | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
+ | otherwise = withTmpDir (toOsPath "tmprepo") $ \tmpdir -> do
unlessM (boolSystem "git" [Param "init", File tmpdir]) $
giveup $ "failed to create temp repository in " ++ tmpdir
tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir)
- let repoconfig r' = fromRawFilePath (localGitDir r' P.</> "config")
- whenM (doesFileExist (repoconfig r)) $
- L.readFile (repoconfig r) >>= L.writeFile (repoconfig tmpr)
+ let repoconfig r' = toOsPath (localGitDir r' P.</> "config")
+ whenM (doesFileExist (fromRawFilePath (fromOsPath (repoconfig r)))) $
+ F.readFile (repoconfig r) >>= F.writeFile (repoconfig tmpr)
rs <- Construct.fromRemotes r
stillmissing <- pullremotes tmpr rs fetchrefstags missing
if S.null (knownMissing stillmissing)
- Relies on packed refs being exploded before it's called.
-}
getAllRefs :: Repo -> IO [Ref]
-getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs")
+getAllRefs r = getAllRefs' (localGitDir r P.</> "refs")
-getAllRefs' :: FilePath -> IO [Ref]
+getAllRefs' :: RawFilePath -> IO [Ref]
getAllRefs' refdir = do
- let topsegs = length (splitPath refdir) - 1
+ let topsegs = length (P.splitPath refdir) - 1
let toref = Ref . toInternalGitPath . encodeBS
- . joinPath . drop topsegs . splitPath
+ . joinPath . drop topsegs . splitPath
+ . decodeBS
map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir)
explodePackedRefsFile :: Repo -> IO ()
let f = packedRefsFile r
let f' = toRawFilePath f
whenM (doesFileExist f) $ do
- rs <- mapMaybe parsePacked . lines
+ rs <- mapMaybe parsePacked
+ . map decodeBS
+ . fileLines'
<$> catchDefaultIO "" (safeReadFile f')
forM_ rs makeref
removeWhenExistsWith R.removeLink f'
-}
preRepair :: Repo -> IO ()
preRepair g = do
- unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do
+ unlessM (validhead <$> catchDefaultIO "" (decodeBS <$> safeReadFile headfile)) $ do
removeWhenExistsWith R.removeLink headfile
writeFile (fromRawFilePath headfile) "ref: refs/heads/master"
explodePackedRefsFile g
successfulRepair :: (Bool, [Branch]) -> Bool
successfulRepair = fst
-safeReadFile :: RawFilePath -> IO String
+safeReadFile :: RawFilePath -> IO B.ByteString
safeReadFile f = do
allowRead f
- readFileStrict (fromRawFilePath f)
+ F.readFile' (toOsPath f)
"1" -> Just True
"0" -> Just False
_ -> Nothing
- t <- parsePOSIXTime ts
+ t <- parsePOSIXTime (encodeBS ts)
return (b, t)
import qualified Git.LsTree
import qualified Git.Tree
import Annex.UUID
+import qualified Utility.FileIO as F
import qualified Data.Map as M
import qualified Data.ByteString as B
getExportExcluded u = do
logf <- fromRepo $ gitAnnexExportExcludeLog u
liftIO $ catchDefaultIO [] $ exportExcludedParser
- <$> L.readFile (fromRawFilePath logf)
+ <$> F.readFile (toOsPath logf)
where
exportExcludedParser :: L.ByteString -> [Git.Tree.TreeItem]
import Annex.LockFile
import Annex.ReplaceFile
import Utility.Tmp
+import qualified Utility.FileIO as F
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
-- making the new file have whatever permissions the git repository is
-- configured to use. Creates the parent directory when necessary.
writeLogFile :: RawFilePath -> String -> Annex ()
-writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (fromRawFilePath f) c
+writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (toOsPath f) c
where
writelog tmp c' = do
- liftIO $ writeFile tmp c'
- setAnnexFilePerm (toRawFilePath tmp)
+ liftIO $ writeFile (fromRawFilePath (fromOsPath tmp)) c'
+ setAnnexFilePerm (fromOsPath tmp)
-- | Runs the action with a handle connected to a temp file.
-- The temp file replaces the log file once the action succeeds.
withLogHandle :: RawFilePath -> (Handle -> Annex a) -> Annex a
withLogHandle f a = do
createAnnexDirectory (parentDir f)
- replaceGitAnnexDirFile (fromRawFilePath f) $ \tmp ->
+ replaceGitAnnexDirFile f $ \tmp ->
bracket (setup tmp) cleanup a
where
setup tmp = do
setAnnexFilePerm tmp
- liftIO $ openFile (fromRawFilePath tmp) WriteMode
+ liftIO $ F.openFile (toOsPath tmp) WriteMode
cleanup h = liftIO $ hClose h
-- | Appends a line to a log file, first locking it to prevent
appendLogFile f lck c =
createDirWhenNeeded f $
withExclusiveLock lck $ do
- liftIO $ withFile f' AppendMode $
+ liftIO $ F.withFile (toOsPath f) AppendMode $
\h -> L8.hPutStrLn h c
- setAnnexFilePerm (toRawFilePath f')
- where
- f' = fromRawFilePath f
+ setAnnexFilePerm f
-- | Modifies a log file.
--
modifyLogFile :: RawFilePath -> RawFilePath -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
modifyLogFile f lck modf = withExclusiveLock lck $ do
ls <- liftIO $ fromMaybe []
- <$> tryWhenExists (fileLines <$> L.readFile f')
+ <$> tryWhenExists (fileLines <$> F.readFile f')
let ls' = modf ls
when (ls' /= ls) $
createDirWhenNeeded f $
viaTmp writelog f' (L8.unlines ls')
where
- f' = fromRawFilePath f
+ f' = toOsPath f
writelog lf b = do
- liftIO $ L.writeFile lf b
- setAnnexFilePerm (toRawFilePath lf)
+ liftIO $ F.writeFile lf b
+ setAnnexFilePerm (fromOsPath lf)
-- | Checks the content of a log file to see if any line matches.
checkLogFile :: RawFilePath -> RawFilePath -> (L.ByteString -> Bool) -> Annex Bool
checkLogFile f lck matchf = withSharedLock lck $ bracket setup cleanup go
where
- setup = liftIO $ tryWhenExists $ openFile f' ReadMode
+ setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
cleanup Nothing = noop
cleanup (Just h) = liftIO $ hClose h
go Nothing = return False
go (Just h) = do
!r <- liftIO (any matchf . fileLines <$> L.hGetContents h)
return r
- f' = fromRawFilePath f
-- | Folds a function over lines of a log file to calculate a value.
calcLogFile :: RawFilePath -> RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t
calcLogFileUnsafe :: RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t
calcLogFileUnsafe f start update = bracket setup cleanup go
where
- setup = liftIO $ tryWhenExists $ openFile f' ReadMode
+ setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
cleanup Nothing = noop
cleanup (Just h) = liftIO $ hClose h
go Nothing = return start
go' v (l:ls) = do
let !v' = update l v
go' v' ls
- f' = fromRawFilePath f
-- | Streams lines from a log file, passing each line to the processor,
-- and then empties the file at the end.
--
-- Locking is used to prevent writes to to the log file while this
-- is running.
-streamLogFile :: FilePath -> RawFilePath -> Annex () -> (String -> Annex ()) -> Annex ()
+streamLogFile :: RawFilePath -> RawFilePath -> Annex () -> (String -> Annex ()) -> Annex ()
streamLogFile f lck finalizer processor =
withExclusiveLock lck $ do
streamLogFileUnsafe f finalizer processor
- liftIO $ writeFile f ""
- setAnnexFilePerm (toRawFilePath f)
+ liftIO $ F.writeFile' (toOsPath f) mempty
+ setAnnexFilePerm f
-- Unsafe version that does not do locking, and does not empty the file
-- at the end.
-streamLogFileUnsafe :: FilePath -> Annex () -> (String -> Annex ()) -> Annex ()
+streamLogFileUnsafe :: RawFilePath -> Annex () -> (String -> Annex ()) -> Annex ()
streamLogFileUnsafe f finalizer processor = bracketOnError setup cleanup go
where
- setup = liftIO $ tryWhenExists $ openFile f ReadMode
+ setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
cleanup Nothing = noop
cleanup (Just h) = liftIO $ hClose h
go Nothing = finalizer
-- done if writing the file fails.
createAnnexDirectory (parentDir f)
a
-
--- On windows, readFile does NewlineMode translation,
--- stripping CR before LF. When converting to ByteString,
--- use this to emulate that.
-fileLines :: L.ByteString -> [L.ByteString]
-#ifdef mingw32_HOST_OS
-fileLines = map stripCR . L8.lines
- where
- stripCR b = case L8.unsnoc b of
- Nothing -> b
- Just (b', e)
- | e == '\r' -> b'
- | otherwise -> b
-#else
-fileLines = L8.lines
-#endif
-
-fileLines' :: S.ByteString -> [S.ByteString]
-#ifdef mingw32_HOST_OS
-fileLines' = map stripCR . S8.lines
- where
- stripCR b = case S8.unsnoc b of
- Nothing -> b
- Just (b', e)
- | e == '\r' -> b'
- | otherwise -> b
-#else
-fileLines' = S8.lines
-#endif
-- | Commits a migration to the git-annex branch.
commitMigration :: Annex ()
commitMigration = do
- logf <- fromRawFilePath <$> fromRepo gitAnnexMigrateLog
+ logf <- fromRepo gitAnnexMigrateLog
lckf <- fromRepo gitAnnexMigrateLock
nv <- liftIO $ newTVarIO (0 :: Integer)
g <- Annex.gitRepo
import Logs.File
import Utility.InodeCache
import Annex.LockFile
+import qualified Utility.FileIO as F
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
streamRestageLog finalizer processor = do
logf <- fromRepo gitAnnexRestageLog
oldf <- fromRepo gitAnnexRestageLogOld
- let oldf' = fromRawFilePath oldf
lckf <- fromRepo gitAnnexRestageLock
withExclusiveLock lckf $ liftIO $
whenM (R.doesPathExist logf) $
ifM (R.doesPathExist oldf)
( do
- h <- openFile oldf' AppendMode
+ h <- F.openFile (toOsPath oldf) AppendMode
hPutStr h =<< readFile (fromRawFilePath logf)
hClose h
liftIO $ removeWhenExistsWith R.removeLink logf
, moveFile logf oldf
)
- streamLogFileUnsafe oldf' finalizer $ \l ->
+ streamLogFileUnsafe oldf finalizer $ \l ->
case parseRestageLog l of
Just (f, ic) -> processor f ic
Nothing -> noop
streamSmudged a = do
logf <- fromRepo gitAnnexSmudgeLog
lckf <- fromRepo gitAnnexSmudgeLock
- streamLogFile (fromRawFilePath logf) lckf noop $ \l ->
+ streamLogFile logf lckf noop $ \l ->
case parse l of
Nothing -> noop
Just (k, f) -> a k f
import Utility.TimeStamp
import Logs.File
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
#ifndef mingw32_HOST_OS
import Annex.Perms
#endif
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Control.Concurrent.STM
+import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified System.FilePath.ByteString as P
(Just oldlck, _) -> getLockStatus oldlck
case v' of
StatusLockedBy pid -> liftIO $ catchDefaultIO Nothing $
- readTransferInfoFile (Just pid) (fromRawFilePath tfile)
+ readTransferInfoFile (Just pid) tfile
_ -> do
mode <- annexFileMode
-- Ignore failure due to permissions, races, etc.
v <- liftIO $ lockShared lck
liftIO $ case v of
Nothing -> catchDefaultIO Nothing $
- readTransferInfoFile Nothing (fromRawFilePath tfile)
+ readTransferInfoFile Nothing tfile
Just lockhandle -> do
dropLock lockhandle
deletestale
infos <- mapM checkTransfer transfers
return $ mapMaybe running $ zip transfers infos
where
- findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath)
+ findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive)
=<< mapM (fromRepo . transferDir) dirs
running (t, Just i) = Just (t, i)
running (_, Nothing) = Nothing
return $ case (mt, mi) of
(Just t, Just i) -> Just (t, i)
_ -> Nothing
- findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath)
+ findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive)
=<< mapM (fromRepo . failedTransferDir u) [Download, Upload]
clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]
P.</> keyFile (mkKey (const kd))
{- Parses a transfer information filename to a Transfer. -}
-parseTransferFile :: FilePath -> Maybe Transfer
+parseTransferFile :: RawFilePath -> Maybe Transfer
parseTransferFile file
- | "lck." `isPrefixOf` takeFileName file = Nothing
+ | "lck." `B.isPrefixOf` P.takeFileName file = Nothing
| otherwise = case drop (length bits - 3) bits of
[direction, u, key] -> Transfer
<$> parseDirection direction
<*> pure (toUUID u)
- <*> fmap (fromKey id) (fileKey (toRawFilePath key))
+ <*> fmap (fromKey id) (fileKey key)
_ -> Nothing
where
- bits = splitDirectories file
+ bits = P.splitDirectories file
writeTransferInfoFile :: TransferInfo -> RawFilePath -> Annex ()
writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info
in maybe "" fromRawFilePath afile
]
-readTransferInfoFile :: Maybe PID -> FilePath -> IO (Maybe TransferInfo)
+readTransferInfoFile :: Maybe PID -> RawFilePath -> IO (Maybe TransferInfo)
readTransferInfoFile mpid tfile = catchDefaultIO Nothing $
- readTransferInfo mpid <$> readFileStrict tfile
+ readTransferInfo mpid . decodeBS <$> F.readFile' (toOsPath tfile)
readTransferInfo :: Maybe PID -> String -> Maybe TransferInfo
readTransferInfo mpid s = TransferInfo
<*> pure False
where
#ifdef mingw32_HOST_OS
- (firstline, otherlines) = separate (== '\n') s
- (secondline, rest) = separate (== '\n') otherlines
+ (firstliner, otherlines) = separate (== '\n') s
+ (secondliner, rest) = separate (== '\n') otherlines
+ firstline = dropWhileEnd (== '\r') firstliner
+ secondline = dropWhileEnd (== '\r') secondliner
mpid' = readish secondline
#else
(firstline, rest) = separate (== '\n') s
bits = splitc ' ' firstline
numbits = length bits
time = if numbits > 0
- then Just <$> parsePOSIXTime =<< headMaybe bits
+ then Just <$> parsePOSIXTime . encodeBS =<< headMaybe bits
else pure Nothing -- not failure
bytes = if numbits > 1
then Just <$> readish =<< headMaybe (drop 1 bits)
import qualified Data.Set as S
import Data.Time.Clock.POSIX
import Data.Time
+import qualified Utility.FileIO as F
import Annex.Common
import qualified Annex
readUnusedLog :: RawFilePath -> Annex UnusedLog
readUnusedLog prefix = do
- f <- fromRawFilePath <$> fromRepo (gitAnnexUnusedLog prefix)
- ifM (liftIO $ doesFileExist f)
- ( M.fromList . mapMaybe parse . lines
- <$> liftIO (readFileStrict f)
+ f <- fromRepo (gitAnnexUnusedLog prefix)
+ ifM (liftIO $ doesFileExist (fromRawFilePath f))
+ ( M.fromList . mapMaybe (parse . decodeBS) . fileLines'
+ <$> liftIO (F.readFile' (toOsPath f))
, return M.empty
)
where
- parse line = case (readish sint, deserializeKey skey, parsePOSIXTime ts) of
+ parse line = case (readish sint, deserializeKey skey, parsePOSIXTime (encodeBS ts)) of
(Just int, Just key, mtimestamp) -> Just (key, (int, mtimestamp))
_ -> Nothing
where
import Utility.TimeStamp
import Logs.File
import Types.RepoVersion
+import qualified Utility.FileIO as F
import Data.Time.Clock.POSIX
readUpgradeLog :: Annex [(RepoVersion, POSIXTime)]
readUpgradeLog = do
- logfile <- fromRawFilePath <$> fromRepo gitAnnexUpgradeLog
- ifM (liftIO $ doesFileExist logfile)
- ( mapMaybe parse . lines
- <$> liftIO (readFileStrict logfile)
+ logfile <- fromRepo gitAnnexUpgradeLog
+ ifM (liftIO $ doesFileExist (fromRawFilePath logfile))
+ ( mapMaybe (parse . decodeBS) . fileLines'
+ <$> liftIO (F.readFile' (toOsPath logfile))
, return []
)
where
- parse line = case (readish sint, parsePOSIXTime ts) of
+ parse line = case (readish sint, parsePOSIXTime (encodeBS ts)) of
(Just v, Just t) -> Just (RepoVersion v, t)
_ -> Nothing
where
import Network.URI
import qualified System.FilePath.ByteString as P
+import qualified Data.ByteString as S
#ifdef WITH_TORRENTPARSER
import Data.Torrent
-import qualified Data.ByteString.Lazy as B
+import qualified Utility.FileIO as F
#endif
remote :: RemoteType
let metadir = othertmp P.</> "torrentmeta" P.</> kf
createAnnexDirectory metadir
showOutput
- ok <- downloadMagnetLink u
- (fromRawFilePath metadir)
- (fromRawFilePath torrent)
+ ok <- downloadMagnetLink u metadir torrent
liftIO $ removeDirectoryRecursive
(fromRawFilePath metadir)
return ok
else withOtherTmp $ \othertmp -> do
- withTmpFileIn (fromRawFilePath othertmp) "torrent" $ \f h -> do
+ withTmpFileIn (toOsPath othertmp) (toOsPath "torrent") $ \f h -> do
liftIO $ hClose h
- resetAnnexFilePerm (toRawFilePath f)
+ resetAnnexFilePerm (fromOsPath f)
ok <- Url.withUrlOptions $
- Url.download nullMeterUpdate Nothing u f
+ Url.download nullMeterUpdate Nothing u (fromRawFilePath (fromOsPath f))
when ok $
- liftIO $ moveFile (toRawFilePath f) torrent
+ liftIO $ moveFile (fromOsPath f) torrent
return ok
)
-downloadMagnetLink :: URLString -> FilePath -> FilePath -> Annex Bool
+downloadMagnetLink :: URLString -> RawFilePath -> RawFilePath -> Annex Bool
downloadMagnetLink u metadir dest = ifM download
( liftIO $ do
- ts <- filter (".torrent" `isSuffixOf`)
+ ts <- filter (".torrent" `S.isSuffixOf`)
<$> dirContents metadir
case ts of
(t:[]) -> do
- moveFile (toRawFilePath t) (toRawFilePath dest)
+ moveFile t dest
return True
_ -> return False
, return False
, Param "--seed-time=0"
, Param "--summary-interval=0"
, Param "-d"
- , File metadir
+ , File (fromRawFilePath metadir)
]
downloadTorrentContent :: Key -> URLString -> FilePath -> Int -> MeterUpdate -> Annex Bool
torrentFileSizes torrent = do
#ifdef WITH_TORRENTPARSER
let mkfile = joinPath . map (scrub . decodeBL)
- b <- B.readFile (fromRawFilePath torrent)
+ b <- F.readFile (toOsPath torrent)
return $ case readTorrent b of
Left e -> giveup $ "failed to parse torrent: " ++ e
Right t -> case tInfo t of
removeDirGeneric,
) where
-import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import qualified Data.List.NonEmpty as NE
import qualified System.FilePath.ByteString as P
import Utility.FileMode
import Utility.Directory.Create
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
#ifndef mingw32_HOST_OS
import Utility.OpenFd
#endif
- down. -}
finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO ()
finalizeStoreGeneric d tmp dest = do
- removeDirGeneric False (fromRawFilePath d) dest'
+ removeDirGeneric False d dest
createDirectoryUnder [d] (parentDir dest)
renameDirectory (fromRawFilePath tmp) dest'
-- may fail on some filesystems
void $ tryIO $ do
- mapM_ (preventWrite . toRawFilePath) =<< dirContents dest'
+ mapM_ preventWrite =<< dirContents dest
preventWrite dest
where
dest' = fromRawFilePath dest
src <- liftIO $ fromRawFilePath <$> getLocation d k
void $ liftIO $ fileCopier cow src (fromRawFilePath dest) p iv
retrieveKeyFileM d _ _ = byteRetriever $ \k sink ->
- sink =<< liftIO (L.readFile . fromRawFilePath =<< getLocation d k)
+ sink =<< liftIO (F.readFile . toOsPath =<< getLocation d k)
retrieveKeyFileCheapM :: RawFilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())
-- no cheap retrieval possible for chunks
#endif
removeKeyM :: RawFilePath -> Remover
-removeKeyM d _proof k = liftIO $ removeDirGeneric True
- (fromRawFilePath d)
- (fromRawFilePath (storeDir d k))
+removeKeyM d _proof k = liftIO $ removeDirGeneric True d (storeDir d k)
{- Removes the directory, which must be located under the topdir.
-
- can also be removed. Failure to remove such a directory is not treated
- as an error.
-}
-removeDirGeneric :: Bool -> FilePath -> FilePath -> IO ()
+removeDirGeneric :: Bool -> RawFilePath -> RawFilePath -> IO ()
removeDirGeneric removeemptyparents topdir dir = do
- void $ tryIO $ allowWrite (toRawFilePath dir)
+ void $ tryIO $ allowWrite dir
#ifdef mingw32_HOST_OS
{- Windows needs the files inside the directory to be writable
- before it can delete them. -}
- void $ tryIO $ mapM_ (allowWrite . toRawFilePath) =<< dirContents dir
+ void $ tryIO $ mapM_ allowWrite =<< dirContents dir
#endif
- tryNonAsync (removeDirectoryRecursive dir) >>= \case
+ tryNonAsync (removeDirectoryRecursive dir') >>= \case
Right () -> return ()
Left e ->
- unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $
+ unlessM (doesDirectoryExist topdir' <&&> (not <$> doesDirectoryExist dir')) $
throwM e
when removeemptyparents $ do
- subdir <- relPathDirToFile (toRawFilePath topdir) (P.takeDirectory (toRawFilePath dir))
+ subdir <- relPathDirToFile topdir (P.takeDirectory dir)
goparents (Just (P.takeDirectory subdir)) (Right ())
where
goparents _ (Left _e) = return ()
goparents Nothing _ = return ()
goparents (Just subdir) _ = do
- let d = topdir </> fromRawFilePath subdir
+ let d = topdir' </> fromRawFilePath subdir
goparents (upFrom subdir) =<< tryIO (removeDirectory d)
+ dir' = fromRawFilePath dir
+ topdir' = fromRawFilePath topdir
checkPresentM :: RawFilePath -> ChunkConfig -> CheckPresent
checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations' k
liftIO $ createDirectoryUnder [d] (P.takeDirectory dest)
-- Write via temp file so that checkPresentGeneric will not
-- see it until it's fully stored.
- viaTmp go (fromRawFilePath dest) ()
+ viaTmp go (toOsPath dest) ()
where
dest = exportPath d loc
- go tmp () = void $ liftIO $ fileCopier cow src tmp p Nothing
+ go tmp () = void $ liftIO $ fileCopier cow src (fromRawFilePath (fromOsPath tmp)) p Nothing
retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification
retrieveExportM d cow k loc dest p =
listImportableContentsM :: IgnoreInodes -> RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))
listImportableContentsM ii dir = liftIO $ do
- l <- dirContentsRecursiveSkipping (const False) False (fromRawFilePath dir)
- l' <- mapM (go . toRawFilePath) l
+ l' <- mapM go =<< dirContentsRecursiveSkipping (const False) False dir
return $ Just $ ImportableContentsComplete $
ImportableContents (catMaybes l') []
where
storeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do
- liftIO $ createDirectoryUnder [dir] (toRawFilePath destdir)
- withTmpFileIn destdir template $ \tmpf tmph -> do
+ liftIO $ createDirectoryUnder [dir] destdir
+ withTmpFileIn (toOsPath destdir) template $ \tmpf tmph -> do
+ let tmpf' = fromOsPath tmpf
liftIO $ hClose tmph
- void $ liftIO $ fileCopier cow src tmpf p Nothing
- let tmpf' = toRawFilePath tmpf
+ void $ liftIO $ fileCopier cow src (fromRawFilePath tmpf') p Nothing
resetAnnexFilePerm tmpf'
liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf' >>= \case
Nothing -> giveup "unable to generate content identifier"
return newcid
where
dest = exportPath dir loc
- (destdir, base) = splitFileName (fromRawFilePath dest)
- template = relatedTemplate (base ++ ".tmp")
+ (destdir, base) = P.splitFileName dest
+ template = relatedTemplate (base <> ".tmp")
removeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
removeExportWithContentIdentifierM ii dir k loc removeablecids =
import Utility.Metered
import Utility.Directory.Create
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool
withCheckedFiles _ [] _locations _ _ = return False
retrieve locations d basek p _dest miv c = withOtherTmp $ \tmpdir -> do
showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow."
let tmp = tmpdir P.</> keyFile basek <> ".directorylegacy.tmp"
- let tmp' = fromRawFilePath tmp
+ let tmp' = toOsPath tmp
let go = \k sink -> do
liftIO $ void $ withStoredFiles (fromRawFilePath d) (legacyLocations locations) k $ \fs -> do
forM_ fs $
- S.appendFile tmp' <=< S.readFile
+ F.appendFile' tmp' <=< S.readFile
return True
- b <- liftIO $ L.readFile tmp'
+ b <- liftIO $ F.readFile tmp'
liftIO $ removeWhenExistsWith R.removeLink tmp
sink b
byteRetriever go basek p tmp miv c
remove' repo r rsyncopts accessmethod proof k
| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $
liftIO $ Remote.Directory.removeDirGeneric True
- (gCryptTopDir repo)
- (fromRawFilePath (parentDir (toRawFilePath (gCryptLocation repo k))))
+ (toRawFilePath (gCryptTopDir repo))
+ (parentDir (toRawFilePath (gCryptLocation repo k)))
| Git.repoIsSsh repo = shellOrRsync r removeshell removersync
| accessmethod == AccessRsyncOverSsh = removersync
| otherwise = unsupportedUrl
let (rsynctransport, rsyncurl, _) = rsyncTransport r gc
opts <- rsynctransport
liftIO $ do
- withTmpFile "tmpconfig" $ \tmpconfig _ -> do
+ withTmpFile (toOsPath "tmpconfig") $ \tmpconfig _ -> do
+ let tmpconfig' = fromRawFilePath $ fromOsPath tmpconfig
void $ rsync $ opts ++
[ Param $ rsyncurl ++ "/config"
- , Param tmpconfig
+ , Param tmpconfig'
]
- Git.Config.fromFile r tmpconfig
+ Git.Config.fromFile r tmpconfig'
geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do
let url = Git.repoLocation r ++ "/config"
- v <- withTmpFile "git-annex.tmp" $ \tmpfile h -> do
+ v <- withTmpFile (toOsPath "git-annex.tmp") $ \tmpfile h -> do
liftIO $ hClose h
- Url.download' nullMeterUpdate Nothing url tmpfile uo >>= \case
+ let tmpfile' = fromRawFilePath $ fromOsPath tmpfile
+ Url.download' nullMeterUpdate Nothing url tmpfile' uo >>= \case
Right () ->
pipedconfig Git.Config.ConfigNullList
False url "git"
, Param "--null"
, Param "--list"
, Param "--file"
- , File tmpfile
+ , File tmpfile'
] >>= return . \case
Right r' -> Right r'
Left exitcode -> Left $ "git config exited " ++ show exitcode
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Remote.Helper.Git where
import Annex.Common
import System.PosixCompat.Files (modificationTime)
import qualified Data.Map as M
import qualified Data.Set as S
+import qualified System.FilePath.ByteString as P
repoCheap :: Git.Repo -> Bool
repoCheap = not . Git.repoIsUrl
gitRepoInfo :: Remote -> Annex [(String, String)]
gitRepoInfo r = do
- d <- fromRawFilePath <$> fromRepo Git.localGitDir
- mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus (toRawFilePath p))
- =<< emptyWhenDoesNotExist (dirContentsRecursive (d </> "refs" </> "remotes" </> Remote.name r))
+ d <- fromRepo Git.localGitDir
+ mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus p)
+ =<< emptyWhenDoesNotExist (dirContentsRecursive (d P.</> "refs" P.</> "remotes" P.</> encodeBS (Remote.name r)))
let lastsynctime = case mtimes of
[] -> "never"
_ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes
withRsyncScratchDir :: (FilePath -> Annex a) -> Annex a
withRsyncScratchDir a = do
t <- fromRawFilePath <$> fromRepo gitAnnexTmpObjectDir
- withTmpDirIn t "rsynctmp" a
+ withTmpDirIn t (toOsPath "rsynctmp") a
rsyncRetrieve :: RsyncOpts -> [RsyncUrl] -> FilePath -> Maybe MeterUpdate -> Annex ()
rsyncRetrieve o rsyncurls dest meterupdate =
#endif
test_import :: Assertion
-test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir "importtest" $ \importdir -> do
+test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "importtest")) $ \importdir -> do
(toimport1, importf1, imported1) <- mktoimport importdir "import1"
git_annex "import" [toimport1] "import"
annexed_present_imported imported1
testscheme "pubkey"
where
gpgcmd = Utility.Gpg.mkGpgCmd Nothing
- testscheme scheme = Utility.Tmp.Dir.withTmpDir "gpgtmp" $ \gpgtmp -> do
+ testscheme scheme = Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "gpgtmp")) $ \gpgtmp -> do
-- Use the system temp directory as gpg temp directory because
-- it needs to be able to store the agent socket there,
-- which can be problematic when testing some filesystems.
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Test.Framework where
import Test.Tasty
- happen concurrently with a test case running, and would be a problem
- since setEnv is not thread safe. This is run before tasty. -}
setTestEnv :: IO a -> IO a
-setTestEnv a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do
+setTestEnv a = Utility.Tmp.Dir.withTmpDir (toOsPath "testhome") $ \tmphome -> do
tmphomeabs <- fromRawFilePath <$> absPath (toRawFilePath tmphome)
{- Prevent global git configs from affecting the test suite. -}
Utility.Env.Set.setEnv "HOME" tmphomeabs True
cleanup :: FilePath -> IO ()
cleanup dir = whenM (doesDirectoryExist dir) $ do
- Command.Uninit.prepareRemoveAnnexDir' dir
+ Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath dir)
-- This can fail if files in the directory are still open by a
-- subprocess.
void $ tryIO $ removeDirectoryForCleanup dir
finalCleanup :: IO ()
finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
- Command.Uninit.prepareRemoveAnnexDir' tmpdir
+ Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath tmpdir)
catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do
print e
putStrLn "sleeping 10 seconds and will retry directory cleanup"
formatDirection Upload = "upload"
formatDirection Download = "download"
-parseDirection :: String -> Maybe Direction
+parseDirection :: B.ByteString -> Maybe Direction
parseDirection "upload" = Just Upload
parseDirection "download" = Just Download
parseDirection _ = Nothing
formatInfoFile d = replace "keyVariant = " "keyBackendName = " (show d) ++
"\n" ++ formatGitAnnexDistribution d
-parseInfoFile :: String -> Maybe GitAnnexDistribution
-parseInfoFile s = case lines s of
- (_oldformat:rest) -> parseGitAnnexDistribution (unlines rest)
- _ -> Nothing
+parseInfoFile :: [String] -> Maybe GitAnnexDistribution
+parseInfoFile (_oldformat:rest) = parseGitAnnexDistribution (unlines rest)
+parseInfoFile _ = Nothing
formatGitAnnexDistribution :: GitAnnexDistribution -> String
formatGitAnnexDistribution d = unlines
import Data.ByteString.Builder
import qualified Data.ByteString as S
import qualified Data.ByteString.Short as S (toShort, fromShort)
-import qualified Data.ByteString.Lazy as L
import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isRegularFile)
import Text.Read
import Utility.Tmp
import qualified Upgrade.V2
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
-- v2 adds hashing of filenames of content and location log files.
-- Key information is encoded in filenames differently, so
replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file
writeLog1 :: FilePath -> [LogLine] -> IO ()
-writeLog1 file ls = viaTmp L.writeFile file (toLazyByteString $ buildLog ls)
+writeLog1 file ls = viaTmp F.writeFile
+ (toOsPath (toRawFilePath file))
+ (toLazyByteString $ buildLog ls)
readLog1 :: FilePath -> IO [LogLine]
readLog1 file = catchDefaultIO [] $
- parseLog . encodeBL <$> readFileStrict file
+ parseLog <$> F.readFile (toOsPath (toRawFilePath file))
lookupKey1 :: FilePath -> Annex (Maybe (Key, Backend))
lookupKey1 file = do
import Utility.Tmp
import Logs
import Messages.Progress
+import qualified Utility.FileIO as F
olddir :: Git.Repo -> FilePath
olddir g
config <- Annex.getGitConfig
dir <- fromRepo gitStateDir
liftIO $ do
- levela <- dirContents dir
+ levela <- dirContents (toRawFilePath dir)
levelb <- mapM tryDirContents levela
files <- mapM tryDirContents (concat levelb)
return $ mapMaybe (islogfile config) (concat files)
where
tryDirContents d = catchDefaultIO [] $ dirContents d
- islogfile config f = maybe Nothing (\k -> Just (k, f)) $
- locationLogFileKey config (toRawFilePath f)
+ islogfile config f = maybe Nothing (\k -> Just (k, fromRawFilePath f)) $
+ locationLogFileKey config f
inject :: FilePath -> FilePath -> Annex ()
inject source dest = do
gitAttributesUnWrite :: Git.Repo -> IO ()
gitAttributesUnWrite repo = do
- let attributes = fromRawFilePath (Git.attributes repo)
- whenM (doesFileExist attributes) $ do
- c <- readFileStrict attributes
- liftIO $ viaTmp writeFile attributes $ unlines $
- filter (`notElem` attrLines) $ lines c
- Git.Command.run [Param "add", File attributes] repo
+ let attributes = Git.attributes repo
+ let attributes' = fromRawFilePath attributes
+ whenM (doesFileExist attributes') $ do
+ c <- map decodeBS . fileLines'
+ <$> F.readFile' (toOsPath attributes)
+ liftIO $ viaTmp (writeFile . fromRawFilePath . fromOsPath)
+ (toOsPath attributes)
+ (unlines $ filter (`notElem` attrLines) c)
+ Git.Command.run [Param "add", File attributes'] repo
stateDir :: FilePath
stateDir = addTrailingPathSeparator ".git-annex"
import Utility.DottedVersion
import Annex.AdjustedBranch
import qualified Utility.RawFilePath as R
-
-import qualified Data.ByteString as S
+import qualified Utility.FileIO as F
upgrade :: Bool -> Annex UpgradeResult
upgrade automatic = flip catchNonAsync onexception $ do
Just k -> do
stagePointerFile f Nothing =<< hashPointerFile k
ifM (isJust <$> getAnnexLinkTarget f)
- ( writepointer (fromRawFilePath f) k
+ ( writepointer f k
, fromdirect (fromRawFilePath f) k
)
Database.Keys.addAssociatedFile k
)
writepointer f k = liftIO $ do
- removeWhenExistsWith R.removeLink (toRawFilePath f)
- S.writeFile f (formatPointer k)
+ removeWhenExistsWith R.removeLink f
+ F.writeFile' (toOsPath f) (formatPointer k)
{- Remove all direct mode bookkeeping files. -}
removeDirectCruft :: Annex ()
import Utility.InodeCache
import Annex.InodeSentinal
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
setIndirect :: Annex ()
setIndirect = do
- the top of the repo. -}
associatedFilesRelative :: Key -> Annex [FilePath]
associatedFilesRelative key = do
- mapping <- fromRawFilePath <$> calcRepo (gitAnnexMapping key)
- liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h ->
+ mapping <- calcRepo (gitAnnexMapping key)
+ liftIO $ catchDefaultIO [] $ F.withFile (toOsPath mapping) ReadMode $ \h ->
-- Read strictly to ensure the file is closed promptly
lines <$> hGetContentsStrict h
recordedInodeCache :: Key -> Annex [InodeCache]
recordedInodeCache key = withInodeCacheFile key $ \f ->
liftIO $ catchDefaultIO [] $
- mapMaybe readInodeCache . lines
- <$> readFileStrict (fromRawFilePath f)
+ mapMaybe (readInodeCache . decodeBS) . fileLines'
+ <$> F.readFile' (toOsPath f)
{- Removes an inode cache. -}
removeInodeCache :: Key -> Annex ()
import Git.FilePath
import Config
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isSymbolicLink)
-- checked into the repository.
updateSmudgeFilter :: Annex ()
updateSmudgeFilter = do
- lf <- fromRawFilePath <$> Annex.fromRepo Git.attributesLocal
- ls <- liftIO $ lines <$> catchDefaultIO "" (readFileStrict lf)
+ lf <- Annex.fromRepo Git.attributesLocal
+ ls <- liftIO $ map decodeBS . fileLines'
+ <$> catchDefaultIO "" (F.readFile' (toOsPath lf))
let ls' = removedotfilter ls
when (ls /= ls') $
- liftIO $ writeFile lf (unlines ls')
+ liftIO $ writeFile (fromRawFilePath lf) (unlines ls')
where
removedotfilter ("* filter=annex":".* !filter":rest) =
"* filter=annex" : removedotfilter rest
prefix = pidfile ++ "."
suffix = ".lck"
cleanstale = mapM_ (void . tryIO . removeFile) =<<
- (filter iswinlockfile <$> dirContents (fromRawFilePath (parentDir (toRawFilePath pidfile))))
+ (filter iswinlockfile . map fromRawFilePath <$> dirContents (parentDir (toRawFilePath pidfile)))
iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f
#endif
scan d = unless (ignoredPath ignored d) $
-- Do not follow symlinks when scanning.
-- This mirrors the inotify startup scan behavior.
- mapM_ go =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d)
+ mapM_ (go . fromRawFilePath) =<< emptyWhenDoesNotExist
+ (dirContentsRecursiveSkipping (const False) False (toRawFilePath d))
where
go f
| ignoredPath ignored f = noop
void (addWatch i watchevents (toInternalFilePath dir) handler)
`catchIO` failedaddwatch
withLock lock $
- mapM_ scan =<< filter (not . dirCruft) <$>
+ mapM_ scan =<< filter (not . dirCruft . toRawFilePath) <$>
getDirectoryContents dir
where
recurse d = watchDir i d ignored scanevents hooks
getDirInfo :: FilePath -> IO DirInfo
getDirInfo dir = do
- l <- filter (not . dirCruft) <$> getDirectoryContents dir
+ l <- filter (not . dirCruft . toRawFilePath) <$> getDirectoryContents dir
contents <- S.fromList . catMaybes <$> mapM getDirEnt l
return $ DirInfo dir contents
where
runhook h s = maybe noop (\a -> a (filePath evt) s) (h hooks)
scan d = unless (ignoredPath ignored d) $
- mapM_ go =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d)
+ mapM_ (go . fromRawFilePath) =<< emptyWhenDoesNotExist
+ (dirContentsRecursiveSkipping (const False) False (toRawFilePath d))
where
go f
| ignoredPath ignored f = noop
{- directory traversal and manipulation
-
- - Copyright 2011-2023 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2025 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.Directory (
- module Utility.Directory,
- module Utility.SystemDirectory
-) where
+module Utility.Directory where
+#ifdef WITH_OSPATH
+import System.Directory.OsPath
+#else
+import Utility.SystemDirectory
+#endif
import Control.Monad
-import System.FilePath
import System.PosixCompat.Files (isDirectory, isSymbolicLink)
import Control.Applicative
import System.IO.Unsafe (unsafeInterleaveIO)
+import qualified System.FilePath.ByteString as P
import Data.Maybe
import Prelude
-import Utility.SystemDirectory
+import Utility.OsPath
import Utility.Exception
import Utility.Monad
import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R
-dirCruft :: FilePath -> Bool
+dirCruft :: R.RawFilePath -> Bool
dirCruft "." = True
dirCruft ".." = True
dirCruft _ = False
{- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -}
-dirContents :: FilePath -> IO [FilePath]
-dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
+dirContents :: RawFilePath -> IO [RawFilePath]
+dirContents d =
+ map (\p -> d P.</> fromOsPath p)
+ . filter (not . dirCruft . fromOsPath)
+ <$> getDirectoryContents (toOsPath d)
{- Gets files in a directory, and then its subdirectories, recursively,
- and lazily.
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
-dirContentsRecursive :: FilePath -> IO [FilePath]
+dirContentsRecursive :: RawFilePath -> IO [RawFilePath]
dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
{- Skips directories whose basenames match the skipdir. -}
-dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
+dirContentsRecursiveSkipping :: (RawFilePath -> Bool) -> Bool -> RawFilePath -> IO [RawFilePath]
dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
- | skipdir (takeFileName topdir) = return []
+ | skipdir (P.takeFileName topdir) = return []
| otherwise = do
-- Get the contents of the top directory outside of
-- unsafeInterleaveIO, which allows throwing exceptions if
where
go [] = return []
go (dir:dirs)
- | skipdir (takeFileName dir) = go dirs
+ | skipdir (P.takeFileName dir) = go dirs
| otherwise = unsafeInterleaveIO $ do
(files, dirs') <- collect [] []
=<< catchDefaultIO [] (dirContents dir)
files' <- go (dirs' ++ dirs)
return (files ++ files')
+
+ collect :: [RawFilePath] -> [RawFilePath] -> [RawFilePath] -> IO ([RawFilePath], [RawFilePath])
collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries)
| dirCruft entry = collect files dirs' entries
| otherwise = do
let skip = collect (entry:files) dirs' entries
let recurse = collect files (entry:dirs') entries
- ms <- catchMaybeIO $ R.getSymbolicLinkStatus (toRawFilePath entry)
+ ms <- catchMaybeIO $ R.getSymbolicLinkStatus entry
case ms of
(Just s)
| isDirectory s -> recurse
| isSymbolicLink s && followsubdirsymlinks ->
- ifM (doesDirectoryExist entry)
+ ifM (doesDirectoryExist (toOsPath entry))
( recurse
, skip
)
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
-dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
+dirTreeRecursiveSkipping :: (RawFilePath -> Bool) -> RawFilePath -> IO [RawFilePath]
dirTreeRecursiveSkipping skipdir topdir
- | skipdir (takeFileName topdir) = return []
+ | skipdir (P.takeFileName topdir) = return []
| otherwise = do
subdirs <- filterM isdir =<< dirContents topdir
go [] subdirs
where
go c [] = return c
go c (dir:dirs)
- | skipdir (takeFileName dir) = go c dirs
+ | skipdir (P.takeFileName dir) = go c dirs
| otherwise = unsafeInterleaveIO $ do
subdirs <- go []
=<< filterM isdir
=<< catchDefaultIO [] (dirContents dir)
go (subdirs++dir:c) dirs
- isdir p = isDirectory <$> R.getSymbolicLinkStatus (toRawFilePath p)
+ isdir p = isDirectory <$> R.getSymbolicLinkStatus p
{- When the action fails due to the directory not existing, returns []. -}
emptyWhenDoesNotExist :: IO [a] -> IO [a]
-{- streaming directory traversal
+{- streaming directory reading
-
- - Copyright 2011-2018 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2025 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
openDirectory,
closeDirectory,
readDirectory,
- isDirectoryEmpty,
+ isDirectoryPopulated,
) where
import Control.Monad
-import System.FilePath
import Control.Concurrent
import Data.Maybe
import Prelude
#ifdef mingw32_HOST_OS
import qualified System.Win32 as Win32
+import System.FilePath
#else
-import qualified System.Posix as Posix
+import qualified Data.ByteString as B
+import qualified System.Posix.Directory.ByteString as Posix
#endif
import Utility.Directory
import Utility.Exception
+import Utility.FileSystemEncoding
#ifndef mingw32_HOST_OS
data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
type IsOpen = MVar () -- full when the handle is open
-openDirectory :: FilePath -> IO DirectoryHandle
+openDirectory :: RawFilePath -> IO DirectoryHandle
openDirectory path = do
#ifndef mingw32_HOST_OS
dirp <- Posix.openDirStream path
isopen <- newMVar ()
return (DirectoryHandle isopen dirp)
#else
- (h, fdat) <- Win32.findFirstFile (path </> "*")
+ (h, fdat) <- Win32.findFirstFile (fromRawFilePath path </> "*")
-- Indicate that the fdat contains a filename that readDirectory
-- has not yet returned, by making the MVar be full.
-- (There's always at least a "." entry.)
-- | Reads the next entry from the handle. Once the end of the directory
-- is reached, returns Nothing and automatically closes the handle.
-readDirectory :: DirectoryHandle -> IO (Maybe FilePath)
+readDirectory :: DirectoryHandle -> IO (Maybe RawFilePath)
#ifndef mingw32_HOST_OS
readDirectory hdl@(DirectoryHandle _ dirp) = do
e <- Posix.readDirStream dirp
- if null e
+ if B.null e
then do
closeDirectory hdl
return Nothing
where
getfn = do
filename <- Win32.getFindDataFileName fdat
- return (Just filename)
+ return (Just (toRawFilePath filename))
#endif
--- | True only when directory exists and contains nothing.
--- Throws exception if directory does not exist.
-isDirectoryEmpty :: FilePath -> IO Bool
-isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check
+-- | True only when directory exists and is not empty.
+isDirectoryPopulated :: RawFilePath -> IO Bool
+isDirectoryPopulated d = bracket (openDirectory d) closeDirectory check
+ `catchIO` const (return False)
where
check h = do
v <- readDirectory h
case v of
- Nothing -> return True
+ Nothing -> return False
Just f
- | not (dirCruft f) -> return False
+ | not (dirCruft f) -> return True
| otherwise -> check h
--- /dev/null
+{- File IO on OsPaths.
+ -
+ - Since Prelude exports many of these as well, this needs to be imported
+ - qualified.
+ -
+ - Copyright 2025 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Utility.FileIO
+(
+ withFile,
+ openFile,
+ readFile,
+ readFile',
+ writeFile,
+ writeFile',
+ appendFile,
+ appendFile',
+ openTempFile,
+) where
+
+#ifdef WITH_OSPATH
+
+#ifndef mingw32_HOST_OS
+import System.File.OsPath
+#else
+-- On Windows, System.File.OsPath does not handle UNC-style conversion itself,
+-- so that has to be done when calling it. See
+-- https://github.com/haskell/file-io/issues/39
+import Utility.Path.Windows
+import Utility.OsPath
+import System.IO (IO, Handle, IOMode)
+import qualified System.File.OsPath as O
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import Control.Applicative
+
+withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
+withFile f m a = do
+ f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
+ O.withFile f' m a
+
+openFile :: OsPath -> IOMode -> IO Handle
+openFile f m = do
+ f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
+ O.openFile f' m
+
+readFile :: OsPath -> IO L.ByteString
+readFile f = do
+ f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
+ O.readFile f'
+
+readFile' :: OsPath -> IO B.ByteString
+readFile' f = do
+ f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
+ O.readFile' f'
+
+writeFile :: OsPath -> L.ByteString -> IO ()
+writeFile f b = do
+ f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
+ O.writeFile f' b
+
+writeFile' :: OsPath -> B.ByteString -> IO ()
+writeFile' f b = do
+ f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
+ O.writeFile' f' b
+
+appendFile :: OsPath -> L.ByteString -> IO ()
+appendFile f b = do
+ f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
+ O.appendFile f' b
+
+appendFile' :: OsPath -> B.ByteString -> IO ()
+appendFile' f b = do
+ f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
+ O.appendFile' f' b
+
+openTempFile :: OsPath -> OsPath -> IO (OsPath, Handle)
+openTempFile p s = do
+ p' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath p)
+ O.openTempFile p' s
+#endif
+
+#else
+-- When not building with OsPath, export FilePath versions
+-- instead. However, functions still use ByteString for the
+-- file content in that case, unlike the Strings used by the Prelude.
+import Utility.OsPath
+import System.IO (withFile, openFile, openTempFile, IO)
+import Data.ByteString.Lazy (readFile, writeFile, appendFile)
+import qualified Data.ByteString as B
+
+readFile' :: OsPath -> IO B.ByteString
+readFile' = B.readFile
+
+writeFile' :: OsPath -> B.ByteString -> IO ()
+writeFile' = B.writeFile
+
+appendFile' :: OsPath -> B.ByteString -> IO ()
+appendFile' = B.appendFile
+#endif
import Utility.Exception
import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
+import Utility.OsPath
{- Applies a conversion function to a file's mode. -}
modifyFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO ()
writeFileProtected' file writer = bracket setup cleanup writer
where
setup = do
- h <- protectedOutput $ openFile (fromRawFilePath file) WriteMode
+ h <- protectedOutput $ F.openFile (toOsPath file) WriteMode
void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
return h
cleanup = hClose
#ifdef mingw32_HOST_OS
import Control.Exception (bracket)
import System.IO
-import Utility.FileSystemEncoding
+import qualified Utility.FileIO as F
+import Utility.OsPath
#else
import System.PosixCompat.Files (fileSize)
#endif
#ifndef mingw32_HOST_OS
getFileSize f = fmap (fromIntegral . fileSize) (R.getFileStatus f)
#else
-getFileSize f = bracket (openFile (fromRawFilePath f) ReadMode) hClose hFileSize
+getFileSize f = bracket (F.openFile (toOsPath f) ReadMode) hClose hFileSize
#endif
{- Gets the size of the file, when its FileStatus is already known.
import qualified GHC.Foreign as GHC
import System.IO.Unsafe
import Data.ByteString.Unsafe (unsafePackMallocCStringLen)
+import Data.Char
+import Data.List
#endif
{- Makes all subsequent Handles that are opened, as well as stdio Handles,
- Avoids returning an invalid part of a unicode byte sequence, at the
- cost of efficiency when running on a large FilePath.
-}
-truncateFilePath :: Int -> FilePath -> FilePath
+truncateFilePath :: Int -> RawFilePath -> RawFilePath
#ifndef mingw32_HOST_OS
-truncateFilePath n = go . reverse
+{- On unix, do not assume a unicode locale, but does assume ascii
+ - characters are a single byte. -}
+truncateFilePath n b =
+ let blen = S.length b
+ in if blen <= n
+ then b
+ else go blen (reverse (fromRawFilePath b))
where
- go f =
- let b = encodeBS f
- in if S.length b <= n
- then reverse f
- else go (drop 1 f)
+ go blen f = case uncons f of
+ Just (c, f')
+ | isAscii c ->
+ let blen' = blen - 1
+ in if blen' <= n
+ then toRawFilePath (reverse f')
+ else go blen' f'
+ | otherwise ->
+ let blen' = S.length (toRawFilePath f')
+ in if blen' <= n
+ then toRawFilePath (reverse f')
+ else go blen' f'
+ Nothing -> toRawFilePath (reverse f)
#else
{- On Windows, count the number of bytes used by each utf8 character. -}
-truncateFilePath n = reverse . go [] n . L8.fromString
+truncateFilePath n = toRawFilePath . reverse . go [] n
where
go coll cnt bs
| cnt <= 0 = coll
- | otherwise = case L8.decode bs of
- Just (c, x) | c /= L8.replacement_char ->
+ | otherwise = case S8.decode bs of
+ Just (c, x) | c /= S8.replacement_char ->
let x' = fromIntegral x
in if cnt - x' < 0
then coll
- else go (c:coll) (cnt - x') (L8.drop 1 bs)
+ else go (c:coll) (cnt - x') (S8.drop 1 bs)
_ -> coll
#endif
go (passphrasefd ++ params)
#else
-- store the passphrase in a temp file for gpg
- withTmpFile "gpg" $ \tmpfile h -> do
+ withTmpFile (toOsPath "gpg") $ \tmpfile h -> do
liftIO $ B.hPutStr h passphrase
liftIO $ hClose h
- let passphrasefile = [Param "--passphrase-file", File tmpfile]
+ let passphrasefile = [Param "--passphrase-file", File (fromRawFilePath (fromOsPath tmpfile))]
go $ passphrasefile ++ params
#endif
where
) where
import Author
+import qualified Utility.FileIO as F
+import Utility.RawFilePath
+import Utility.OsPath
import Text.HTML.TagSoup
import System.IO
-- It would be equivalent to use isHtml <$> readFile file,
-- but since that would not read all of the file, the handle
-- would remain open until it got garbage collected sometime later.
-isHtmlFile :: FilePath -> IO Bool
-isHtmlFile file = withFile file ReadMode $ \h ->
+isHtmlFile :: RawFilePath -> IO Bool
+isHtmlFile file = F.withFile (toOsPath file) ReadMode $ \h ->
isHtmlBs <$> B.hGet h htmlPrefixLength
-- | How much of the beginning of a html document is needed to detect it.
(inode:size:mtime:mtimedecimal:_) -> do
i <- readish inode
sz <- readish size
- t <- parsePOSIXTime $ mtime ++ '.' : mtimedecimal
+ t <- parsePOSIXTime $ encodeBS $ mtime ++ '.' : mtimedecimal
return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t)
_ -> Nothing
import Utility.PartialPrelude
import Utility.Directory
+import Utility.SystemDirectory
import Utility.Process
import Utility.Monad
import Utility.Path
import Utility.Exception
import Utility.Applicative
import Utility.Directory
+import Utility.SystemDirectory
import Utility.Monad
import Utility.Path.AbsRel
import Utility.FileMode
import Utility.Env
import Utility.Env.Set
import Utility.Tmp
+import Utility.RawFilePath
+import Utility.OsPath
import qualified Utility.LockFile.Posix as Posix
import System.IO
_ -> return (Just ParentLocked)
where
go abslockfile sidelock = do
- let abslockfile' = fromRawFilePath abslockfile
- (tmp, h) <- openTmpFileIn (takeDirectory abslockfile') "locktmp"
- let tmp' = toRawFilePath tmp
+ (tmp, h) <- openTmpFileIn
+ (toOsPath (P.takeDirectory abslockfile))
+ (toOsPath "locktmp")
+ let tmp' = fromOsPath tmp
setFileMode tmp' (combineModes readModes)
hPutStr h . show =<< mkPidLock
hClose h
-- with the SAME FILENAME exist.
checkInsaneLustre :: RawFilePath -> IO Bool
checkInsaneLustre dest = do
- let dest' = fromRawFilePath dest
- fs <- dirContents (takeDirectory dest')
- case length (filter (== dest') fs) of
+ fs <- dirContents (P.takeDirectory dest)
+ case length (filter (== dest) fs) of
1 -> return False -- whew!
0 -> return True -- wtf?
_ -> do
-- Try to clean up the extra copy we made
-- that has the same name. Egads.
- _ <- tryIO $ removeFile dest'
+ _ <- tryIO $ removeLink dest
return True
-- | Waits as necessary to take a lock.
return $ if h == iNVALID_HANDLE_VALUE
then Nothing
else Just h
-#endif
where
security_attributes = maybePtr Nothing
+#endif
dropLock :: LockHandle -> IO ()
dropLock = closeHandle
{- misc utility functions
-
- - Copyright 2010-2011 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2025 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Misc (
hGetContentsStrict,
- readFileStrict,
separate,
separate',
separateEnd',
firstLine,
firstLine',
+ fileLines,
+ fileLines',
+ linesFile,
+ linesFile',
segment,
segmentDelim,
massReplace,
import System.Exit
import Control.Applicative
import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy.Char8 as L8
import Prelude
{- A version of hgetContents that is not lazy. Ensures file is
hGetContentsStrict :: Handle -> IO String
hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s
-{- A version of readFile that is not lazy. -}
-readFileStrict :: FilePath -> IO String
-readFileStrict = readFile >=> \s -> length s `seq` return s
-
{- Like break, but the item matching the condition is not included
- in the second result list.
-
where
nl = fromIntegral (ord '\n')
+-- On windows, readFile does NewlineMode translation,
+-- stripping CR before LF. When converting to ByteString,
+-- use this to emulate that.
+fileLines :: L.ByteString -> [L.ByteString]
+#ifdef mingw32_HOST_OS
+fileLines = map stripCR . L8.lines
+ where
+ stripCR b = case L8.unsnoc b of
+ Nothing -> b
+ Just (b', e)
+ | e == '\r' -> b'
+ | otherwise -> b
+#else
+fileLines = L8.lines
+#endif
+
+fileLines' :: S.ByteString -> [S.ByteString]
+#ifdef mingw32_HOST_OS
+fileLines' = map stripCR . S8.lines
+ where
+ stripCR b = case S8.unsnoc b of
+ Nothing -> b
+ Just (b', e)
+ | e == '\r' -> b'
+ | otherwise -> b
+#else
+fileLines' = S8.lines
+#endif
+
+-- One windows, writeFile does NewlineMode translation,
+-- adding CR before LF. When converting to ByteString, use this to emulate that.
+linesFile :: L.ByteString -> L.ByteString
+#ifndef mingw32_HOST_OS
+linesFile = id
+#else
+linesFile = L8.concat . concatMap (\x -> [x, L8.pack "\r\n"]) . fileLines
+#endif
+
+linesFile' :: S.ByteString -> S.ByteString
+#ifndef mingw32_HOST_OS
+linesFile' = id
+#else
+linesFile' = S8.concat . concatMap (\x -> [x, S8.pack "\r\n"]) . fileLines'
+#endif
+
{- Splits a list into segments that are delimited by items matching
- a predicate. (The delimiters are not included in the segments.)
- Segments may be empty. -}
import Utility.Exception
import Utility.Monad
import Utility.FileSystemEncoding
+import Utility.OsPath
import qualified Utility.RawFilePath as R
import Author
onrename (Left e)
| isPermissionError e = rethrow
| isDoesNotExistError e = rethrow
- | otherwise = viaTmp mv (fromRawFilePath dest) ()
+ | otherwise = viaTmp mv (toOsPath dest) ()
where
rethrow = throwM e
mv tmp () = do
+ let tmp' = fromRawFilePath (fromOsPath tmp)
-- copyFile is likely not as optimised as
-- the mv command, so we'll use the command.
--
ok <- copyright =<< boolSystem "mv"
[ Param "-f"
, Param (fromRawFilePath src)
- , Param tmp
+ , Param tmp'
]
let e' = e
#else
- r <- tryIO $ copyFile (fromRawFilePath src) tmp
+ r <- tryIO $ copyFile (fromRawFilePath src) tmp'
let (ok, e') = case r of
Left err -> (False, err)
Right _ -> (True, e)
#endif
unless ok $ do
-- delete any partial
- _ <- tryIO $ removeFile tmp
+ _ <- tryIO $ removeFile tmp'
throwM e'
#ifndef mingw32_HOST_OS
--- /dev/null
+{- OsPath utilities
+ -
+ - Copyright 2025 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PackageImports #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.OsPath (
+ OsPath,
+ OsString,
+ toOsPath,
+ fromOsPath,
+) where
+
+import Utility.FileSystemEncoding
+
+#ifdef WITH_OSPATH
+import System.OsPath
+import "os-string" System.OsString.Internal.Types
+import qualified Data.ByteString.Short as S
+#if defined(mingw32_HOST_OS)
+import GHC.IO (unsafePerformIO)
+import System.OsString.Encoding.Internal (cWcharsToChars_UCS2)
+import qualified System.OsString.Data.ByteString.Short.Word16 as BS16
+#endif
+
+toOsPath :: RawFilePath -> OsPath
+#if defined(mingw32_HOST_OS)
+-- On Windows, OsString contains a ShortByteString that is
+-- utf-16 encoded. So have to convert the input to that.
+-- This is relatively expensive.
+toOsPath = unsafePerformIO . encodeFS . fromRawFilePath
+#else
+toOsPath = OsString . PosixString . S.toShort
+#endif
+
+fromOsPath :: OsPath -> RawFilePath
+#if defined(mingw32_HOST_OS)
+-- On Windows, OsString contains a ShortByteString that is
+-- utf-16 encoded. So have to convert the input from that.
+-- This is relatively expensive.
+fromOsPath = toRawFilePath . cWcharsToChars_UCS2 . BS16.unpack . getWindowsString . getOsString
+#else
+fromOsPath = S.fromShort . getPosixString . getOsString
+#endif
+
+#else
+{- When not building with WITH_OSPATH, use FilePath. This allows
+ - using functions from legacy FilePath libraries interchangeably with
+ - newer OsPath libraries.
+ -}
+type OsPath = FilePath
+
+type OsString = String
+
+toOsPath :: RawFilePath -> OsPath
+toOsPath = fromRawFilePath
+
+fromOsPath :: OsPath -> RawFilePath
+fromOsPath = toRawFilePath
+#endif
import Utility.UserInfo
import Utility.Tmp
import Utility.FileMode
+import qualified Utility.FileIO as F
import Data.Char
import Data.Ord
import Data.Either
import System.PosixCompat.Files (groupWriteMode, otherWriteMode)
+import qualified Data.ByteString.Char8 as S8
data SshConfig
= GlobalConfig SshSetting
sshdir <- sshDir
let configfile = sshdir </> "config"
whenM (doesFileExist configfile) $ do
- c <- readFileStrict configfile
+ c <- decodeBS . S8.unlines . fileLines'
+ <$> F.readFile' (toOsPath (toRawFilePath configfile))
let c' = modifier c
when (c /= c') $ do
-- If it's a symlink, replace the file it
-- points to.
f <- catchDefaultIO configfile (canonicalizePath configfile)
- viaTmp writeSshConfig f c'
+ viaTmp writeSshConfig (toOsPath (toRawFilePath f)) c'
-writeSshConfig :: FilePath -> String -> IO ()
+writeSshConfig :: OsPath -> String -> IO ()
writeSshConfig f s = do
- writeFile f s
- setSshConfigMode (toRawFilePath f)
+ F.writeFile' f (linesFile' (encodeBS s))
+ setSshConfigMode (fromOsPath f)
{- Ensure that the ssh config file lacks any group or other write bits,
- since ssh is paranoid about not working if other users can write
{- Test a value round-trips through symmetric encryption and decryption. -}
test_encrypt_decrypt_Symmetric :: SOPCmd -> SOPCmd -> Password -> Armoring -> B.ByteString -> IO Bool
test_encrypt_decrypt_Symmetric a b password armoring v = catchBoolIO $
- withTmpDir "test" $ \d -> do
+ withTmpDir (toOsPath "test") $ \d -> do
let ed = EmptyDirectory d
enc <- encryptSymmetric a password ed Nothing armoring
(`B.hPutStr` v) B.hGetContents
go (Just emptydirectory) (passwordfd ++ params)
#else
-- store the password in a temp file
- withTmpFile "sop" $ \tmpfile h -> do
+ withTmpFile (toOsPath "sop") $ \tmpfile h -> do
liftIO $ B.hPutStr h password
liftIO $ hClose h
- let passwordfile = [Param $ "--with-password="++tmpfile]
+ let passwordfile = [Param $ "--with-password=" ++ fromRawFilePath (fromOsPath tmpfile)]
-- Don't need to pass emptydirectory since @FD is not used,
-- and so tmpfile also does not need to be made absolute.
case emptydirectory of
import Data.Ratio
import Control.Applicative
import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as B8
import qualified Data.Attoparsec.ByteString as A
import Data.Attoparsec.ByteString.Char8 (char, decimal, signed, isDigit_w8)
A.parseOnly (decimal <* A.endOfInput) b
return (d, len)
-parsePOSIXTime :: String -> Maybe POSIXTime
-parsePOSIXTime s = eitherToMaybe $
- A.parseOnly (parserPOSIXTime <* A.endOfInput) (B8.pack s)
+parsePOSIXTime :: B.ByteString -> Maybe POSIXTime
+parsePOSIXTime b = eitherToMaybe $
+ A.parseOnly (parserPOSIXTime <* A.endOfInput) b
{- This implementation allows for higher precision in a POSIXTime than
- supported by the system's Double, and avoids the complications of
{- Temporary files.
-
- - Copyright 2010-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2025 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Tmp (
viaTmp,
withTmpFile,
withTmpFileIn,
- relatedTemplate,
openTmpFileIn,
+ relatedTemplate,
+ relatedTemplate',
) where
import System.IO
-import System.FilePath
import System.Directory
import Control.Monad.IO.Class
import System.IO.Error
+import Data.Char
+import qualified Data.ByteString as B
+import qualified System.FilePath.ByteString as P
import Utility.Exception
import Utility.FileSystemEncoding
import Utility.FileMode
import qualified Utility.RawFilePath as R
+import qualified Utility.FileIO as F
+import Utility.OsPath
-type Template = String
+type Template = OsString
{- This is the same as openTempFile, except when there is an
- error, it displays the template as well as the directory,
- to help identify what call was responsible.
-}
-openTmpFileIn :: FilePath -> String -> IO (FilePath, Handle)
-openTmpFileIn dir template = openTempFile dir template
+openTmpFileIn :: OsPath -> Template -> IO (OsPath, Handle)
+openTmpFileIn dir template = F.openTempFile dir template
`catchIO` decoraterrror
where
decoraterrror e = throwM $
- let loc = ioeGetLocation e ++ " template " ++ template
+ let loc = ioeGetLocation e ++ " template " ++ decodeBS (fromOsPath template)
in annotateIOError e loc Nothing Nothing
{- Runs an action like writeFile, writing to a temp file first and
- mode as it would when using writeFile, unless the writer action changes
- it.
-}
-viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m ()
+viaTmp :: (MonadMask m, MonadIO m) => (OsPath -> v -> m ()) -> OsPath -> v -> m ()
viaTmp a file content = bracketIO setup cleanup use
where
- (dir, base) = splitFileName file
- template = relatedTemplate (base ++ ".tmp")
+ (dir, base) = P.splitFileName (fromOsPath file)
+ template = relatedTemplate (base <> ".tmp")
setup = do
- createDirectoryIfMissing True dir
- openTmpFileIn dir template
+ createDirectoryIfMissing True (fromRawFilePath dir)
+ openTmpFileIn (toOsPath dir) template
cleanup (tmpfile, h) = do
_ <- tryIO $ hClose h
- tryIO $ removeFile tmpfile
+ tryIO $ R.removeLink (fromOsPath tmpfile)
use (tmpfile, h) = do
- let tmpfile' = toRawFilePath tmpfile
+ let tmpfile' = fromOsPath tmpfile
-- Make mode the same as if the file were created usually,
-- not as a temp file. (This may fail on some filesystems
-- that don't support file modes well, so ignore
-- exceptions.)
- _ <- liftIO $ tryIO $ R.setFileMode tmpfile' =<< defaultFileMode
+ _ <- liftIO $ tryIO $
+ R.setFileMode (fromOsPath tmpfile)
+ =<< defaultFileMode
liftIO $ hClose h
a tmpfile content
- liftIO $ R.rename tmpfile' (toRawFilePath file)
+ liftIO $ R.rename tmpfile' (fromOsPath file)
{- Runs an action with a tmp file located in the system's tmp directory
- (or in "." if there is none) then removes the file. -}
-withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a
+withTmpFile :: (MonadIO m, MonadMask m) => Template -> (OsPath -> Handle -> m a) -> m a
withTmpFile template a = do
tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
- withTmpFileIn tmpdir template a
+ withTmpFileIn (toOsPath (toRawFilePath tmpdir)) template a
{- Runs an action with a tmp file located in the specified directory,
- then removes the file.
- Note that the tmp file will have a file mode that only allows the
- current user to access it.
-}
-withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a
+withTmpFileIn :: (MonadIO m, MonadMask m) => OsPath -> Template -> (OsPath -> Handle -> m a) -> m a
withTmpFileIn tmpdir template a = bracket create remove use
where
create = liftIO $ openTmpFileIn tmpdir template
remove (name, h) = liftIO $ do
hClose h
- catchBoolIO (removeFile name >> return True)
+ tryIO $ R.removeLink (fromOsPath name)
use (name, h) = a name h
{- It's not safe to use a FilePath of an existing file as the template
- will be longer, and may exceed the maximum filename length.
-
- This generates a template that is never too long.
- - (Well, it allocates 20 characters for use in making a unique temp file,
- - anyway, which is enough for the current implementation and any
- - likely implementation.)
-}
-relatedTemplate :: FilePath -> FilePath
-relatedTemplate f
- | len > 20 =
+relatedTemplate :: RawFilePath -> Template
+relatedTemplate = toOsPath . relatedTemplate'
+
+relatedTemplate' :: RawFilePath -> RawFilePath
+relatedTemplate' f
+ | len > templateAddedLength =
{- Some filesystems like FAT have issues with filenames
- ending in ".", so avoid truncating a filename to end
- that way. -}
- reverse $ dropWhile (== '.') $ reverse $
- truncateFilePath (len - 20) f
+ B.dropWhileEnd (== dot) $
+ truncateFilePath (len - templateAddedLength) f
| otherwise = f
where
- len = length f
+ len = B.length f
+ dot = fromIntegral (ord '.')
+
+{- When a Template is used to create a temporary file, some random bytes
+ - are appended to it. This is how many such bytes can be added, maximum.
+ -
+ - This needs to be as long or longer than the current implementation
+ - of openTempFile, and some extra has been added to make it longer
+ - than any likely implementation.
+ -}
+templateAddedLength :: Int
+templateAddedLength = 20
import Utility.Exception
import Utility.Tmp (Template)
+import Utility.OsPath
+import Utility.FileSystemEncoding
{- Runs an action with a tmp directory located within the system's tmp
- directory (or within "." if there is none), then removes the tmp
#ifndef mingw32_HOST_OS
-- Use mkdtemp to create a temp directory securely in /tmp.
bracket
- (liftIO $ mkdtemp $ topleveltmpdir </> template)
+ (liftIO $ mkdtemp $ topleveltmpdir </> fromRawFilePath (fromOsPath template))
removeTmpDir
a
#else
where
create = do
createDirectoryIfMissing True tmpdir
- makenewdir (tmpdir </> template) (0 :: Int)
+ makenewdir (tmpdir </> fromRawFilePath (fromOsPath template)) (0 :: Int)
makenewdir t n = do
let dir = t ++ "." ++ show n
catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do
- to avoid exposing the secret token when launching the web browser. -}
writeHtmlShim :: String -> String -> FilePath -> IO ()
writeHtmlShim title url file =
- viaTmp (writeFileProtected . toRawFilePath) file $ genHtmlShim title url
+ viaTmp (writeFileProtected . fromOsPath)
+ (toOsPath $ toRawFilePath file)
+ (genHtmlShim title url)
genHtmlShim :: String -> String -> String
genHtmlShim title url = unlines
Flag Servant
Description: Use the servant library, enabling using annex+http urls and git-annex p2phttp
+Flag OsPath
+ Description: Use the os-string library and related libraries, for faster filename manipulation
+
Flag Benchmark
Description: Enable benchmarking
Default: True
P2P.Http.Server
P2P.Http.State
+ if flag(OsPath)
+ -- Currently this build flag does not pass the test suite on Windows
+ if (! os(windows))
+ Build-Depends:
+ os-string (>= 2.0.0),
+ directory (>= 1.3.8.3),
+ filepath (>= 1.5.2.0),
+ file-io (>= 0.1.3)
+ CPP-Options: -DWITH_OSPATH
+
if (os(windows))
Build-Depends:
Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.4.0),
Utility.OpenFile
Utility.OptParse
Utility.OSX
+ Utility.OsPath
Utility.PID
Utility.PartialPrelude
Utility.Path
Utility.STM
Utility.Su
Utility.SystemDirectory
+ Utility.FileIO
Utility.Terminal
Utility.TimeStamp
Utility.TList
benchmark: true
crypton: true
servant: true
+ ospath: true
packages:
- '.'
-resolver: lts-23.2
+resolver: nightly-2025-01-20
extra-deps:
-- filepath-bytestring-1.4.100.3.2
+- filepath-bytestring-1.5.2.0.2
+- aws-0.24.4
+- git-lfs-1.2.3
+- feed-1.3.2.1
+allow-newer: true
+allow-newer-deps:
+- feed
projects / git-annex.git / commitdiff